Code not appending dbf files correctly

[djl0525]

I use the code below to append csv and txt files into Excel. I recently modified it for dbf files. It brings in all of the data, but it puts the content of an entire dbf file in one cell. I don't know how to make it recognize the delimiters. Any suggestions will be appreciated.

Thank you in advance,
DJ

Sub AppendDBFFiles()
Dim WorkingFile As Workbook
Dim fs As FileSearch
Dim I As Integer
Dim myFile As String
Dim CopyRange As Range
Dim PasteRange As Range
Dim StartingRow As Long
Dim ShtName As String
Dim Confirm As String
Dim wksData As Worksheet 'Used to temporary store the imported data
Dim wksCurrent As Worksheet 'Current worksheet
Dim strWbkName As String

Confirm = MsgBox("This macro will append the .dbf files in the current directory to a single sheet in this workbook." _
& vbNewLine & "" _
& vbNewLine & "You need to know the row number of the columns headings in your .dbf files." _
& vbNewLine & "" _
& vbNewLine & "It is your responsibility to check the integrity of your data." _
& vbNewLine & "" _
& vbNewLine & "Do you want to continue?", vbYesNo + vbQuestion)

Select Case Confirm

Case vbNo
MsgBox "Operation canceled by user."

Case vbYes

Application.ScreenUpdating = False
Set WorkingFile = ActiveWorkbook
Set fs = Application.FileSearch

'Prompt user for new sheetname
ShtName = InputBox("Enter name for new worksheet")

'Prompt user for number of header lines
StartingRow = CLng(InputBox("What row are your column headings on?")) + 1

'add the append worksheet and set paste range
Sheets.Add , ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

On Error Resume Next
ActiveSheet.Name = ShtName
If Err.Number = 1004 Then
MsgBox "Worksheet - (" & ShtName & ") already exists" & _
Chr(10) & "Sheet added is named " & ActiveSheet.Name
ShtName = ActiveSheet.Name
End If
On Error GoTo 0
Set PasteRange = Worksheets(ShtName).Range("A1")

'get the data
With fs
.NewSearch
.LookIn = ActiveWorkbook.Path
.Filename = "*.dbf"
If .Execute > 0 Then

Set wksData = WorkingFile.Worksheets.Add

For I = 1 To .FoundFiles.Count

'Show the progress bar background
ProgressShow

'Set the text of the progress bar
sText = "Appending DBF Files" & Chr(10) & j & Chr(10) & "Please wait..."

ProgressSetText sText, "C"

'Loop to show the percent complete bar
' For I = 1 To 1000
'Update the percent-complete bar
ProgressSetValue I, .FoundFiles.Count
'Next

'Tidy up after the progress bar
ProgressClear


myFile = .FoundFiles(I)

wksData.QueryTables.Add Connection:="TEXT;" & myFile, _
Destination:=wksData.Range("A1")

With wksData.QueryTables(1)
.TextFileCommaDelimiter = True
.Refresh False
End With

If I <> 1 Then
Set CopyRange = Range(Cells(StartingRow, 1), _
wksData.UsedRange.SpecialCells(xlLastCell))
Else
Set CopyRange = wksData.UsedRange
End If

'Copies imported data
CopyRange.Copy Destination:=PasteRange
Set PasteRange = PasteRange.Offset(CopyRange.Rows.Count)

'Clears the data imported
wksData.Cells.Clear

Next

Application.DisplayAlerts = False
wksData.Delete
Application.DisplayAlerts = True

Else
MsgBox "There were no DBF files found."
Exit Sub

Application.ScreenUpdating = False

End If

End With

End Select

MsgBox "Append Complete."

End Sub

 

[Barrie Davidson]

Okay, without being able to test, how about changing

With wksData.QueryTables(1)
    .TextFileCommaDelimiter = True
    .Refresh False
End With

to (deleted the False statement on Refresh)

With wksData.QueryTables(1)
    .TextFileCommaDelimiter = True
    .Refresh
End With

Does that help out?

 

[djl0525]

It still puts the first dbf file in A1, the second file in A2 and so on. My files aren't very big so it manages to cram all the records into one cell. There's something about the way you bring in the data in VMAN's code that works, that is not happening here. If you document VMAN's code like you did this code, I'll play with it over the weekend and maybe I can figure where to plug things in.

'add the append worksheet and set paste range
'get the data
'Copies imported data
'Clears the data imported

When I was playing with it earlier, here is where it got stuck:
PasteRange.Offset(, -1).Value = ActiveWorkbook.Name

Thanks,
DJ

 

[Barrie Davidson]

Here's the code for variable columns with comments.

Sub Main()

Dim fs As FileSearch, i As Integer
Dim LastRow As Long, LastColumn As Integer
Dim PasteRange As Range, CopyRange As Range


Set fs = Application.FileSearch
Set PasteRange = Range("B2") 'the first cell where you paste the data
With fs
    'where to look for the files
    .LookIn = "F:\user\T1 Class Share\_ 00 EPATRAINER1\Add-ins and Macros - Ready For Distribution"
    'file type to search for
    .Filename = "*.dbf"
    If .Execute > 0 Then 'check how many files were found
        For i = 1 To .FoundFiles.Count 'for each file found
            Workbooks.Open Filename:=.FoundFiles(i) 'open the file
            LastRow = Range("A65536").End(xlUp).Row 'get the last row number that contains data
            LastColumn = Range("A1").End(xlToRight).Column 'get the last column number that contains data
            If LastRow > 1 Then 'check that there is data (ie, it's not just the header row)
                Set CopyRange = Range(Cells(2, 1), Cells(LastRow, LastColumn)) 'set the range to copy
                CopyRange.Copy Destination:=PasteRange 'copy that range to the paste range
                PasteRange.Offset(, -1).Value = ActiveWorkbook.Name 'put the file name in column A where the data came from
                Set PasteRange = PasteRange.Offset(CopyRange.Rows.Count) 'reset the paste range
            End If
            ActiveWindow.Close False 'close the file
        Next i 'cycle to next file
        Else 'no files found
            MsgBox "There were no files found."
    End If
End With

End Sub