djl0525
Well-known Member
- Joined
- Dec 11, 2004
- Messages
- 1,240
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
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