Hej,

Jag har gjort ett formulär på en hemsida med frågor som några personer skall besvara. När de har fyllt i alla frågorna och trycker på sändknappen genereras ett meil till Outlook. Till hit är allt frid och fröjd.

Problemet börjar när jag skall hämta upp dessa textfiler för att sammanställa dem i ett excelark. Jag har sparat textfilerna manuellt i en katalog. Tex. pers1.txt, pers2.txt osv.
Jag hade tänkt mig att alla svaren skulle sammanställas i ett Excelark där första kolumnen innehåller frågorna(x antal stycken) och kolumn B innehåller svar från pers1, kolumn C svar från pers2 osv. Eftersom alla svaren i Outlook innehåller två kolumner, den första med frågorna och den andra med svaren, hade jag tänkt att jag skulle filtrera ut kolumnen med frågorna i Excel. Jag hade tänkt att ett och samma macro skulle hantera detta. Jag har börjat med att testa med tre personers svar, men koden skall kunna hantera flera svar, man vet ju inte hur många personer som svarar.....

Eftersom VB var helt nytt för mig så sökte jag på nätet och fick tag i en kod som hanterade textfiler och som jag fick göra om lite.
Problemet är att koden fungerar till viss del, den hämtar en textfil, men sen är det stopp. Den filtrerar ut kolumnsvaren ifrån textfilerna men det går inte att repetera textkodningen. Jag har försökt med en for-loop för att placera svaren i kolumnerna from B osv, då endast den sista medtagna filens svar placeras i Excelarket. Programmet hoppar helt enkelt över den första och andra text filerna. Varför? Jag förstår inte koden riktigt än. Vad är det som är felaktigt? Snälla hjälp mig innan jag blir tokig!!!

Jag skickar med koden får ni titta på den.

Eva


Sub Import_A_File()
Dim destCell As Range, fType As String
Dim uRange As Range, lastCell As Range
Dim rowsAvailable As Long, colsAvailable As Integer

'get the destination cell
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
On Error GoTo doExit
Set destCell = Range("A1")
On Error GoTo 0

'get available rows and columns before copy
With ActiveSheet.Cells
rowsAvailable = Cells(.Count).Row - destCell.Row + 1
colsAvailable = Cells(.Count).Column - destCell.Column + 1
End With

'get the file to open
Dim fNameAndPath As Variant
Application.ScreenUpdating = False

For Kund = 1 To 3
Select Case Kund

Case 1
fNameAndPath = "c:\windows\skrivbord\svar\pers1.txt"
Set destCell = Range("B1")

Case 2
fNameAndPath = "c:\windows\skrivbord\svar\pers2.txt"
Set destCell = Range("C1")

Case 3
fNameAndPath = "c:\windows\skrivbord\svar\pers3.txt"
Set destCell = Range("D1")
End Select

Next Kund

If fNameAndPath = False Then Exit Sub


'make certain it is not a workbook
fType = Right(UCase(fNameAndPath), 3)
If fType Like "XL*" Or fType Like "WK*" Then
MsgBox "Do not select Excel or Lotus files"
Exit Sub
End If

'open the file
On Error GoTo errorOpen
Workbooks.Open fNameAndPath
On Error GoTo 0

'copy data to destination
With ActiveSheet.UsedRange
Set uRange = Range("B1", .Cells(.Count))
Set uRange = Range("C1", .Cells(.Count))
Set uRange = Range("D1", .Cells(.Count))

'make certain there are enough rows and columns first
If uRange.Rows.Count > rowsAvailable Then
MsgBox "You need " & uRange.Rows.Count _
& " rows and there are only " _
& rowsAvailable & " rows available"
ActiveWorkbook.Close False
Exit Sub
ElseIf uRange.Columns.Count > colsAvailable Then
MsgBox "You need " & uRange.Columns.Count _
& " columns and there are only " _
& colsAvailable & " columns available"
ActiveWorkbook.Close False
Exit Sub
End If

'copy imported data to destination
uRange.Copy destCell
ActiveWorkbook.Close False
End With

'clear the clipboard
Application.CutCopyMode = False
Exit Sub
doExit:

'handles cancel selection in input box
Exit Sub
errorOpen:

'handles failure to open file
MsgBox "The file could not be opened."

End Sub

Kanske detta kan vara till nån hjälp?

Public Sub Test2()
Import_A_File "c:\windows\skrivbord\svar\pers1.txt", "B1"
Import_A_File "c:\windows\skrivbord\svar\pers2.txt", "C1"
Import_A_File "c:\windows\skrivbord\svar\pers3.txt", "D1"
End Sub



Sub Import_A_File(FileName As String, RangeName As String)
Dim destCell As Range
Dim fType As String
Dim uRange As Range
Dim lastCell As Range
Dim rowsAvailable As Long
Dim colsAvailable As Long
Dim TempBook As Workbook

'get the destination cell
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub

On Error GoTo doExit
Set destCell = Range(RangeName)
On Error GoTo 0

'get available rows and columns before copy
With ActiveSheet.Cells
rowsAvailable = Cells(.Count).Row - destCell.Row + 1
colsAvailable = Cells(.Count).Column - destCell.Column + 1
End With

'get the file to open

'make certain it is not a workbook
fType = Right(UCase(fNameAndPath), 3)
If fType Like "XL*" Or fType Like "WK*" Then
MsgBox "Do not select Excel or Lotus files"
Exit Sub
End If

'open the file
On Error GoTo errorOpen
Set TempBook = Workbooks.Open(fNameAndPath)
On Error GoTo 0

'copy data to destination
With ActiveSheet.UsedRange
Set uRange = Range("A2", .Cells(.Count))

'make certain there are enough rows and columns first
If uRange.Rows.Count > rowsAvailable Then
MsgBox "You need " & uRange.Rows.Count _
& " rows and there are only " _
& rowsAvailable & " rows available"
ActiveWorkbook.Close False
Exit Sub
ElseIf uRange.Columns.Count > colsAvailable Then
MsgBox "You need " & uRange.Columns.Count _
& " columns and there are only " _
& colsAvailable & " columns available"
ActiveWorkbook.Close False
Exit Sub
End If

'copy imported data to destination
uRange.Copy destCell
End With
TempBook.Close False

'clear the clipboard
Application.CutCopyMode = False

'handles cancel selection in input box
doExit:
Exit Sub

'handles failure to open file
errorOpen:
MsgBox "The file could not be opened."

End Sub