Tuesday, July 24, 2007
Print Structures of dbf files in separate workbooks
Recently, I had the need of printing the data structures of many dbf files. A google search reveled the DBF.COM file that would output dbf file structures, number of records, file name, date of last update, etc.
Download this file here: files/DBF.COM (Caution: I downloaded this file from the internet, and I do not make any warranty of it being spyware or malicious ware free. Use it on your own risk.)
To use this file go to Start>Run>cmd and in DOS type:
Note: cd is used to change the current directory
Here's a print screen:
This will create a file myfilestru.txt in the same directory where your dbf files are residing. This text file will look like this:
Now, that we have a text file all the file structures, we need to create separate workbooks for each dbf file. To do that open this text file in Excel, press Alt + F11 to view the VBA window, double-click the sheet name, and paste this code. After that run this code, and you should have separate workbooks for each dbf file.
Download this file here: files/DBF.COM (Caution: I downloaded this file from the internet, and I do not make any warranty of it being spyware or malicious ware free. Use it on your own risk.)
To use this file go to Start>Run>cmd and in DOS type:
cd C:/
dbf.com > myfilestru.txt
dbf.com > myfilestru.txt
Note: cd is used to change the current directory
Here's a print screen:
This will create a file myfilestru.txt in the same directory where your dbf files are residing. This text file will look like this:
Now, that we have a text file all the file structures, we need to create separate workbooks for each dbf file. To do that open this text file in Excel, press Alt + F11 to view the VBA window, double-click the sheet name, and paste this code. After that run this code, and you should have separate workbooks for each dbf file.
Sub FormatThisFile()
'Define some variables
Dim iLastRow As Integer, i As Integer, sWrkbkNm As String, sNewWrkbkNm As String
Dim iPrevLastRow As Integer, iFirstRow As Integer, iNewWrkbkRow As Integer
On Error GoTo FormatThisFile_Error
'Turn off the screen update to run the macro faster
Application.ScreenUpdating = False
'Refer to the current workbook and sheet1
With ThisWorkbook.Sheets(1)
'get the last row number
iLastRow = .Range("A65536").End(xlUp).Row
i = 1
Do While i < iLastRow
'search for string "Structure for"
If InStr(1, .Range("A" & i), "Structure for") > 0 Then
'if found then store the file name
sWrkbkNm = Trim(Right(.Range("A" & i), Len(.Range("A" & i)) - Application.WorksheetFunction.Find(":", .Range("A" & i))))
sWrkbkNm = Left(sWrkbkNm, Len(sWrkbkNm) - 4)
iFirstRow = i
'search for string "** Total **"
ElseIf InStr(1, .Range("A" & i), "** Total **") > 0 Then
iPrevLastRow = i
'add a workbook
Workbooks.Add
'save it
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sWrkbkNm
sNewWrkbkNm = sWrkbkNm & ".xls"
'with this new workbook do copy-paste
With Workbooks(sNewWrkbkNm)
ThisWorkbook.Sheets(1).Range("A" & iFirstRow & ":" & "A" & iPrevLastRow).Copy Destination:= _
.Sheets(1).Range("A1")
iNewWrkbkRow = .Sheets(1).Range("A65536").End(xlUp).Row
.Sheets(1).Range("A4:A" & iNewWrkbkRow).TextToColumns Destination:= _
.Sheets(1).Range("A4"), DataType:=xlDelimited, Space:=True
.Sheets(1).Range("A5:A" & iNewWrkbkRow - 1).Delete Shift:=xlToLeft
.Sheets(1).Columns("A:IV").EntireColumn.AutoFit
.Sheets(1).Columns("A:IV").WrapText = False
'save and close this workbook
.Save
.Close
End With
End If
i = i + 1
Loop
MsgBox "Done"
End With
On Error GoTo 0
SmoothExit_FormatThisFile:
Application.ScreenUpdating = True
Exit Sub
FormatThisFile_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FormatThisFile"
Resume SmoothExit_FormatThisFile
End Sub
'Define some variables
Dim iLastRow As Integer, i As Integer, sWrkbkNm As String, sNewWrkbkNm As String
Dim iPrevLastRow As Integer, iFirstRow As Integer, iNewWrkbkRow As Integer
On Error GoTo FormatThisFile_Error
'Turn off the screen update to run the macro faster
Application.ScreenUpdating = False
'Refer to the current workbook and sheet1
With ThisWorkbook.Sheets(1)
'get the last row number
iLastRow = .Range("A65536").End(xlUp).Row
i = 1
Do While i < iLastRow
'search for string "Structure for"
If InStr(1, .Range("A" & i), "Structure for") > 0 Then
'if found then store the file name
sWrkbkNm = Trim(Right(.Range("A" & i), Len(.Range("A" & i)) - Application.WorksheetFunction.Find(":", .Range("A" & i))))
sWrkbkNm = Left(sWrkbkNm, Len(sWrkbkNm) - 4)
iFirstRow = i
'search for string "** Total **"
ElseIf InStr(1, .Range("A" & i), "** Total **") > 0 Then
iPrevLastRow = i
'add a workbook
Workbooks.Add
'save it
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sWrkbkNm
sNewWrkbkNm = sWrkbkNm & ".xls"
'with this new workbook do copy-paste
With Workbooks(sNewWrkbkNm)
ThisWorkbook.Sheets(1).Range("A" & iFirstRow & ":" & "A" & iPrevLastRow).Copy Destination:= _
.Sheets(1).Range("A1")
iNewWrkbkRow = .Sheets(1).Range("A65536").End(xlUp).Row
.Sheets(1).Range("A4:A" & iNewWrkbkRow).TextToColumns Destination:= _
.Sheets(1).Range("A4"), DataType:=xlDelimited, Space:=True
.Sheets(1).Range("A5:A" & iNewWrkbkRow - 1).Delete Shift:=xlToLeft
.Sheets(1).Columns("A:IV").EntireColumn.AutoFit
.Sheets(1).Columns("A:IV").WrapText = False
'save and close this workbook
.Save
.Close
End With
End If
i = i + 1
Loop
MsgBox "Done"
End With
On Error GoTo 0
SmoothExit_FormatThisFile:
Application.ScreenUpdating = True
Exit Sub
FormatThisFile_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FormatThisFile"
Resume SmoothExit_FormatThisFile
End Sub
