Code
Code to document tables in a database to Excel
You'll also need the code here:
VBA > Properties > Get and set ... read, write, show, delete
VBA > custom Function > GetDataType
Option Compare Database
Option Explicit
' module: mod_Document_Tables2Excel_s4p
'*************** Code Start *****************************************************
' Purpose : document table structure (optional contents).
' ListOfTables, DataDictionary, Documentation_s4p
' Author : crystal (strive4peace)
' Code List: www.MsAccessGurus.com/code.htm
' This code: https://msaccessgurus.com/VBA/Code/Document_Tables2Excel.htm
' LICENSE
' You may freely use and share this code, but not sell it.
' Keep attribution. Use at your own risk.
'
' ALSO NEEDS:
' VBA > Properties > Get and set ... read, write, show, delete
' http://msaccessgurus.com/VBA/Code/Properties.htm
'
' VBA > custom Function > GetDataType
' http://msaccessgurus.com/VBA/Code/Fx_GetDataType.htm
'-------------------------------------------------------------------------------
' module declarations
'-------------------------------------------------------------------------------
Private rs As DAO.Recordset
Private db As DAO.Database
'-------------------------------------------------------------------------------
' launch_Document_Tables2Excel
'-------------------------------------------------------------------------------
Public Sub launch_Document_Tables2Excel()
' CLICK HERE and RUN!
' PRESS F5 or choose Run menu from menubar
Document_Tables2Excel False
End Sub
'-------------------------------------------------------------------------------
' Document_Tables2Excel
'-------------------------------------------------------------------------------
Public Sub Document_Tables2Excel(Optional pbGetData As Boolean = False)
'210809 ...210820, 220112 strive4peace
'Document all tables in a database to a new Excel workbook in strive4peace folder on desktop
'
'Sheet1 = ListOfTables
'Sheet2 = DataDictionary
'Sheet3 = Documentation
'subsequent sheets are table contents if if pbGetData=true
'columns are best-fit, and text is wrapped is it's long
'data filters are added and columns are frozen
'data has borders
'
' adds yymmdd-hhmm to filename -- so be sure to weed these out!
'CALLs
' FormatSheet
' GetVerifySheetname
' Get_Property
' LoopRecordsToCells
On Error GoTo Proc_Err
'Dimension object variables - Late binding
Dim oExcel As Object _
,oWb As Object _
,oWs As Object
'Early binding for Excel
' Dim oExcel As Excel.Application _
,oWb As Excel.Workbook _
,oWs As Excel.Worksheet
Dim rsTable As DAO.Recordset _
,rsData As DAO.Recordset _
,oTdf As DAO.TableDef _
,oFld As DAO.Field
'Dimension regular variables
Dim sSQL As String _
,sFilename As String _
,sFileThere As String _
,sMsg As String _
,sPath As String _
,sPathFile As String _
,sSheetname As String _
,sTablename As String _
,nRow As Long _
,nRecords As Long _
,nRecordsTotal As Long _
,nEstWidth As Long _
,iFields As Integer _
,iTables As Integer _
,iTable As Integer _
,iField As Integer _
,iNumSheets As Integer _
,iMultiplier As Integer _
,iOverheadSize As Integer _
,i As Integer _
,iPart As Integer _
,booMsg As Boolean _
,nTimerStart As Single _
,vValue As Variant
Dim anRow1() As Long 'last row for each of the tabledefs on DataDictionary
Dim anRow2() As Long 'last row for each of the tabledefs on DataDictionary
Dim aTable() As String 'tablename for design hyperlink display text on ListOfTables
nTimerStart = Timer()
'--- sFilename
'strip extension, replace space with underscore
i = InStrRev(CurrentProject.Name, ".")
If pbGetData <> True Then
sFilename = "TableSummary_"
Else
sFilename = "Tables_"
End If
sFilename = sFilename _
& Replace(Left(CurrentProject.Name,i - 1), " ", "_") _
& "__" & Format(Now, "yymmdd-hhnn")
'--- sPath
sPath = Environ( "USERPROFILE") & "\Desktop\strive4peace\" '220112
'create folder if it doesn't yet exist
If Dir(sPath,vbDirectory) = "" Then
MkDir sPath
DoEvents
End If
sPathFile = sPath & sFilename 'NOTE: doesn't include extension
booMsg = False 'give message that workbook was created
Set db = CurrentDb
'see how many tables need to be documented
iTables = 0
iTable = 0
iPart = 0 'for error handler
sSQL = "SELECT o.Name AS TName " _
& ", o.Type AS iType" _
& ", Switch([Type]=1,'Table'" _
& ",[Type]=4,'ODBC Table'" _
& ",[Type]=6,'Linked Table') AS TType" _
& " FROM MSysObjects AS o" _
& " WHERE((o.Type In (1,4,6)) " _
& " AND(Left([Name],1) <>'~') " _
& " AND(Left([Name],4) <>'MSys') " _
& " AND(Right([Name],5) <>'_Data')" _
& " AND(o.Flags >=0))" _
& " ORDER BY o.Name" _
& ";"
Set rsTable = db.OpenRecordset(sSQL,dbOpenSnapshot)
With rsTable
If Not .EOF Then
'movelast not necessary since snapshot
iTables = .RecordCount
ReDim anRow1(1 To iTables)
ReDim anRow2(1 To iTables)
ReDim aTable(1 To iTables)
Else
MsgBox "No Tables",, "Aborting"
GoTo Proc_Exit
End If
End With
'create a new instance of an Excel application
Set oExcel = CreateObject( "Excel.Application.16")
With oExcel
.Visible = True 'let user see what is happening
.EnableEvents = False 'don't run any code
If pbGetData <> False Then
iNumSheets = iTables + 3 'for ListOfTables, DataDictionary, Documentation
Else
iNumSheets = 3
End If
'save value
i = .SheetsInNewWorkbook
.SheetsInNewWorkbook = iNumSheets
'Add a new Workbook
Set oWb = .Workbooks.Add()
'put old value back
.SheetsInNewWorkbook = i
End With
'-------------------------------------------------------- Tables
'pbGetData
Do While Not rsTable.EOF
'table name
sTablename = rsTable!TName
sSheetname = sTablename
'this shouldn't happen
If Left(sSheetname,4) = "MSys" Then GoTo NextTable
sSQL = "SELECT t.* FROM [" & sTablename & "] t"
'truncate name to 30 characters for Excel (31 max)
If pbGetData <> False And Len(sSheetname) > 30 Then
sSheetname = Left(sSheetname,30)
End If
'Open Recordset
Set rsData = db.OpenRecordset(sSQL)
With rsData
If Not .EOF Then
.MoveLast
.MoveFirst
'count records
nRecords = .RecordCount
nRecordsTotal = nRecordsTotal + nRecords
iFields = .Fields.Count
Else
nRecords = 0
End If
End With
iTable = iTable + 1
aTable(iTable) = sTablename
'Worksheets Collection is 1-based
'Table Index 2
With oWb.Worksheets(1)
.cells(iTable + 1,1).Value = sSheetname
.cells(iTable + 1,2).Value = nRecords
.cells(iTable + 1,3).Value = iFields
End With
If pbGetData <> False Then
Set oWs = oWb.Worksheets(iTable + 3)
With oWs
.Activate
'Write Labels from Field Names
For i = 1 To iFields
.cells(1,i).Value = rsData.Fields(i - 1).Name
Next i
'Rename Individual Worksheet
sSheetname = GetVerifySheetname(oWb,sSheetname)
If sSheetname <> "" Then
.Name = sSheetname
Else
sSheetname = .Name
End If
'write to ListOfTables -- this will be turned into a hyperlink
oWb.Worksheets(1).cells(iTable + 1,1).Value = sSheetname
If nRecords > 0 Then
iPart = 1
'write values to cells
Call LoopRecordsToCells(rsData,oWs)
End If
iPart = 0
Sheet_EndWriteData:
Call FormatSheet(oWs,iFields)
'set margins, orientation, header
With .PageSetup
.PrintTitleRows = "1:1"
.PrintTitleColumns = "A:A"
.RightHeader = "&""Times New Roman,Italic""&10&A - " & Now() & " - &P/&N"
.LeftMargin = oExcel.InchesToPoints(0.5)
.RightMargin = oExcel.InchesToPoints(0.5)
.TopMargin = oExcel.InchesToPoints(0.5)
.BottomMargin = oExcel.InchesToPoints(0.5)
.HeaderMargin = oExcel.InchesToPoints(0.3)
.FooterMargin = oExcel.InchesToPoints(0.3)
.CenterHorizontally = True
.Orientation = 2 'xlLandscape
End With
End With 'Worksheet
End If 'pbGetData
NextTable:
rsData.Close
rsTable.MoveNext
Loop
'done with all the tables
'-------------------------------------------------------- Documentation
iPart = 0
Set oWs = oWb.Worksheets(3)
nRow = 1
With oWs
.Activate
.Name = "Documentation_s4p"
iFields = 4
'column headings
Let .range( "a1").Resize(,4).Value = _
Array( "Sheet", "ColumnName", "Note", "Col#")
'~~~ ListOfTables
'select to add hyperlink
.range( "A2").select
'(Anchor, Address, SubAddress, ScreenTip, TextToDisplay)
With oExcel.Selection.Hyperlinks.Add( _
oExcel.Selection _
, "" _
, "ListOfTables!A1" _
, "go to list of tables" _
, "ListOfTables")
End With
If pbGetData <> False Then
Let .range( "B2").Resize(,2).Value = Array( "A. goto SheetName" _
, "click to jump to sheet with Table data")
Else
Let .range( "B2").Resize(,3).Value = Array( "A. Table" _
, "Table Name", "1")
End If
Let .range( "b3").Resize(,3).Value = Array( "B. #Recs", "number of records", "2")
Let .range( "b4").Resize(,3).Value = Array( "C. #Flds", "number of fields", "3")
Let .range( "b5").Resize(,3).Value = Array( "D. EstWidth", "estimated record width, standard types only", "4")
Let .range( "b6").Resize(,3).Value = Array( "E. goto DataDictionary", "click to jump to table definition", "5")
.range( "A7").select
With oExcel.Selection.Hyperlinks.Add( _
oExcel.Selection _
, "" _
, "DataDictionary!A1" _
, "go to DataDictionary" _
, "DataDictionary")
End With
'~~~ DataDictionary
Let .range( "b7").Resize(,3).Value = Array( "A. Table", "Table name", "1")
Let .range( "b8").Resize(,3).Value = Array( "B. F#", "Field number", "2")
Let .range( "b9").Resize(,3).Value = Array( "C. Field", "Field name", "3")
Let .range( "b10").Resize(,3).Value = Array( "D. DataType", "Data Type", "4")
Let .range( "b11").Resize(,3).Value = Array( "E. Size", "Size (byte)", "5")
Let .range( "b12").Resize(,3).Value = Array( "G. MaxSize", "Max Size", "6")
Let .range( "b13").Resize(,3).Value = Array( "F. Description", "Description", "7")
Let .range( "b14").Resize(,3).Value = Array( "H. Format", "Format", "8")
Let .range( "b15").Resize(,3).Value = Array( "I. Caption", "Caption", "9")
Let .range( "b16").Resize(,3).Value = Array( "J. DefaultValue", "Default Value", "10")
Let .range( "b17").Resize(,3).Value = Array( "K. Expression", "Expression", "11")
Let .range( "b18").Resize(,3).Value = Array( "L. InputMask", "Input Mask", "12")
Let .range( "b19").Resize(,3).Value = Array( "M. ValRule", "Validation Rule", "13")
Let .range( "b20").Resize(,3).Value = Array( "N. ValText", "Validation Text", "14")
Let .range( "b21").Resize(,3).Value = Array( "O. Req", "Required?", "15")
Let .range( "b22").Resize(,3).Value = Array( "P. UC", "Unicode Compression?", "16")
Let .range( "b23").Resize(,3).Value = Array( "Q. EstW", "Estimated Width", "17")
Let .range( "b24").Resize(,3).Value = Array( "R. SumEstW" _
, "Sum of estimated width for standard fields in table.", "18")
If pbGetData <> False Then
'Tables
.range( "a25").Resize(,2).Value = Array( "Tables" _
, "tables with data on different sheets")
.range( "C25").select
With oExcel.Selection.Hyperlinks.Add( _
oExcel.Selection _
, "" _
, "ListOfTables!A1" _
, "go to ListOfTables" _
, "ListOfTables has hyperlinks")
End With
End If
'0=don't wrap columns
Call FormatSheet(oWs,iFields,0)
'attribution and link
.cells(27,1).Value = "This documentation made with Document Tables to Excel, from MsAccessGurus.com"
.range( "a28").select
With oExcel.Selection.Hyperlinks.Add( _
oExcel.Selection _
, "http://msaccessgurus.com/VBA/Code/Document_Tables2Excel.htm" _
, "" _
, "Get VBA to make this documentation" _
, "http://msaccessgurus.com/VBA/Code/Document_Tables2Excel.htm")
End With
End With
'-------------------------------------------------------- DataDictionary
'TableDefs ' sheet2 is tabledefs - fields + properties
Set oWs = oWb.Worksheets(2)
With oWs
.Activate
.Name = "DataDictionary"
iFields = 18
.cells(1,1).Value = "Table"
.cells(1,2).Value = "F#"
.cells(1,3).Value = "Field"
.cells(1,4).Value = "DataType"
.cells(1,5).Value = "Size"
.cells(1,6).Value = "MaxSize"
.cells(1,7).Value = "Description"
.cells(1,8).Value = "Format"
.cells(1,9).Value = "Caption"
.cells(1,10).Value = "DefaultValue"
.cells(1,11).Value = "Expression"
.cells(1,12).Value = "InputMask"
.cells(1,13).Value = "ValRule"
.cells(1,14).Value = "ValText"
.cells(1,15).Value = "Req"
.cells(1,16).Value = "UC"
.cells(1,17).Value = "EstW"
.cells(1,18).Value = "SumEst"
rsTable.MoveFirst
nRow = 2 'labels in 1
anRow1(1) = nRow ' first row
iTable = 0
iField = 0
Do While Not rsTable.EOF
sTablename = rsTable!TName
Set oTdf = db.TableDefs(sTablename)
nEstWidth = 0
iTable = iTable + 1
'loop fields
For Each oFld In oTdf.Fields
iField = oFld.OrdinalPosition
iMultiplier = 1
iOverheadSize = 0
.cells(nRow,1).Value = sTablename
.cells(nRow,2).Value = iField 'F#
.cells(nRow,3).Value = oFld.Name
.cells(nRow,4).Value = GetDataType(oFld.Type)
.cells(nRow,5).Value = oFld.Size
'Description
vValue = Null
vValue = Get_Property( "Description",oFld, "")
If vValue <> "" Then
.cells(nRow,7).Value = vValue
End If
'Format
vValue = Null
vValue = Get_Property( "Format",oFld, "")
If vValue <> "" Then
.cells(nRow,8).Value = vValue
End If
'Caption
vValue = Null
vValue = Get_Property( "Caption",oFld, "")
If vValue <> "" Then
.cells(nRow,9).Value = vValue
End If
'DefaultValue
vValue = Null
vValue = Get_Property( "DefaultValue",oFld, "")
If vValue <> "" Then
.cells(nRow,10).Value = "'" & vValue
End If
'Expression
vValue = Null
vValue = Get_Property( "Expression",oFld, "")
If vValue <> "" Then
.cells(nRow,11).Value = "'" & vValue
End If
'InputMask
vValue = Null
vValue = Get_Property( "InputMask",oFld, "")
If vValue <> "" Then
.cells(nRow,12).Value = vValue
End If
'ValidationRule
vValue = Null
vValue = Get_Property( "ValidationRule",oFld, "")
If vValue <> "" Then
.cells(nRow,13).Value = "'" & vValue
End If
'ValidationText
vValue = Null
vValue = Get_Property( "ValidationText",oFld, "")
If vValue <> "" Then
.cells(nRow,14).Value = "'" & vValue
End If
'Required
vValue = Null
vValue = Get_Property( "Required",oFld,False)
If CBool(Nz(vValue,False)) = True Then
.cells(nRow,15).Value = "R"
End If
If oFld.Type = 10 Or oFld.Type = 12 Then
'MaxSize
sSQL = "SELECT Max(Len([" & oFld.Name & "])) as MaxLenFld " _
& " FROM [" & sTablename & "];"
Set rs = db.OpenRecordset(sSQL)
If Not rs.EOF Then
.cells(nRow,6).Value = rs!MaxLenFld
End If
rs.Close
'UnicodeCompression
vValue = Null
vValue = Get_Property( "UnicodeCompression",oFld,False)
If CBool(Nz(vValue,False)) <> True Then 'no unicode compression
.cells(nRow,16).Value = "No"
iMultiplier = 2
Else
.cells(nRow,16).Value = "+"
End If
'If oFld.Type = 10 Then iOverheadSize = 10 'just a guess! it's something ... Int, Byte, etc may count word space instead
End If
.cells(nRow,17).Value = (oFld.Size * iMultiplier) + iOverheadSize 'provisioning for overhead
nEstWidth = nEstWidth + (oFld.Size * iMultiplier) + iOverheadSize
nRow = nRow + 1
Next oFld
'done with table
'record last row for table
If iTable <= iTables Then
anRow2(iTable) = nRow - 1
End If
'first row for next table
If iTable < iTables Then
anRow1(iTable + 1) = nRow
End If
'could also put hyperlink to DD
'write width to summary sheet
oWb.Worksheets(1).cells(iTable + 1,4).Value = nEstWidth
'write formula to add it up on this sheet
With .cells(anRow1(iTable),18) 'R
.Formula = "=SUM(Q" & anRow1(iTable) _
& ":Q" & anRow2(iTable) & ")"
End With
rsTable.MoveNext
Loop
'last row for last table
anRow2(UBound(aTable)) = nRow
'#cols=iFields
'MaxWidth=40
'True=Add Borders
'D2=ActiveCell -- use for FreezePanes
Call FormatSheet(oWs,iFields,40,True, "D2")
For i = LBound(anRow1) To UBound(anRow1)
'bold tablename in first row
oWs.cells(anRow1(i),1).Font.Bold = True
Next i
End With
'change formulas to values
With oWs.range( "R2:R" & anRow2(iTable))
.copy
.PasteSpecial -4163 'xlPasteValues
oExcel.CutCopyMode = False
End With
oWs.range( "A1").select
'-------------------------------------------------------- ListOfTables
Set oWs = oWb.Worksheets(1) '1st sheet is list of tables
With oWs
.Activate
.Name = "ListOfTables"
If pbGetData <> False Then 'true
.cells(1,1).Value = "Sheet_Table"
Else
.cells(1,1).Value = "Table"
End If
.cells(1,2).Value = "#Recs"
.cells(1,3).Value = "#Flds"
.cells(1,4).Value = "EstWidth"
.cells(1,5).Value = "goto DataDictionary"
iFields = 5
'hyperlinks
For i = 1 To iTables
If pbGetData <> False Then 'has Table data sheets
.range( "A" & (i + 1)).select
sSheetname = oExcel.ActiveCell.Value
'(Anchor, Address, SubAddress, ScreenTip, TextToDisplay)
.Hyperlinks.Add _
oExcel.Selection _
, "" _
,sSheetname & "!A1" _
, "Goto " & sSheetname _
,sSheetname
End If
.range( "E" & (i + 1)).select
'(Anchor, Address, SubAddress, ScreenTip, TextToDisplay)
.Hyperlinks.Add _
oExcel.Selection _
, "" _
, "DataDictionary!A" & anRow1(i) _
, "Definition " & sSheetname _
,aTable(i) 'table name NOT Truncated
Next i
Call FormatSheet(oWs,iFields,0,,,nRow)
'Add note to end of ListOfTables
With .cells(nRow + 2,1)
.Value = "After going to a link and only scrolling, " _
& " press Ctrl-G, ENTER " _
& " to Go back to previous ActiveCell."
.WrapText = True
.Font.Italic = True
End With
'final leave
.range( "A1").select
End With
CheckFile:
'delete file if it already exists
sFileThere = Dir(sPathFile & ".xls*")
If sFileThere <> "" Then
On Error Resume Next
DoEvents
sFileThere = sPath & sFileThere
Kill sFileThere
DoEvents
iPart = 9
On Error GoTo Proc_Err
If Dir(sFileThere) <> "" Then
'file is still there
sMsg = "can't save file: " _
& sFilename _
& vbCrLf & "in path: " & sPath _
& vbCrLf & vbCrLf & "If the file is OPEN," _
& " then CLOSE it and click Yes to replace." _
& vbCrLf & vbCrLf & "Yes = close file manually & replace it." _
& vbCrLf & "No = don't save"
If MsgBox(sMsg,vbYesNo + vbDefaultButton2 _
, "Close file manually and replace it?") _
= vbNo Then
GoTo Proc_Exit
Else
'close file manually
DoEvents
GoTo CheckFile
End If
End If
End If
iPart = 9
'(FileName, FileFormat, Password, WriteResPassword _
,ReadOnlyRecommended,CreateBackup,AccessMode,ConflictResolution _
,AddToMru,TextCodepage,TextVisualLayout,Local)
'XlSaveConflictResolution : xlLocalSessionChanges=2
'XlFileFormat : xlWorkbookDefault=51
oWb.SaveAs sPathFile
DoEvents
iPart = 0
'close workbook, save
With oWb
.Close True,sPathFile
End With
booMsg = True
Proc_Exit:
On Error Resume Next
If Not booMsg Then
oWb.Close False
Set oWb = Nothing
End If
Proc_Exit2:
On Error Resume Next
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
If Not rsData Is Nothing Then
rsData.Close
Set rsData = Nothing
End If
If Not rsTable Is Nothing Then
rsTable.Close
Set rsTable = Nothing
End If
Set db = Nothing
If TypeName(oExcel) <> "Nothing" Then
oExcel.Quit
Set oExcel = Nothing
End If
If booMsg Then
'210514
sMsg = "open folder?" _
& vbCrLf & "Cancel = (Esc) Don't open anything" _
& vbCrLf & vbCrLf & "File is created whether you look or not." _
& vbCrLf & "Remember to delete files you no longer want to look at."
sMsg = sPathFile _
& vbCrLf & vbCrLf & " has been created" _
& vbCrLf & vbCrLf & nRecordsTotal & " Records" _
& " in " & iTables & " tables" _
& vbCrLf & vbCrLf & "Time to execute: " _
& Format(Timer - nTimerStart, "#,###.##") & " seconds" _
& vbCrLf & vbCrLf & sMsg
If MsgBox(sMsg,vbYesNo, "Done") = vbYes Then
' open folder
Call Shell( "Explorer.exe" & " " & sPath,vbNormalFocus)
End If
End If
Exit Sub
Proc_Err:
If iPart = 9 Then
'filename not valid
sMsg = "Filename: " & sPathFile _
& vbCrLf & "isn't valid"
Debug.Print sMsg
MsgBox sMsg,, "Exiting"
iPart = 0
Resume Proc_Exit2
End If
MsgBox Err.Description _
,, "ERROR " & Err.Number _
& " Document_Tables2Excel"
'Stop 'use if code won't break
Resume Proc_Exit
Resume
End Sub
'-------------------------------------------------------------------------------
' FormatSheet
'-------------------------------------------------------------------------------
' helper for Document_Tables2Excel
Private Sub FormatSheet(pWs As Object _
,Optional piNumColumns As Integer = -99 _
,Optional piMaxWidth As Integer = 60 _
,Optional pBorder As Boolean = True _
,Optional psActiveCell As String = "B2" _
,Optional pRETURNLastRow As Long _
)
'210811 strive4peace ... 210823
'piMaxWidth=0 if you don't want to wrap
' send variable for pRETURNLastRow if you want to get the last row back
Dim nCol As Long _
,bWrap As Boolean _
,i As Integer
bWrap = False
With pWs
pRETURNLastRow = .cells(.rows.Count,1).End(-4162).Row 'xlUp=-4162
If piNumColumns < 0 Then
'calculate number of columns if not passed
piNumColumns = .cells(1,.Columns.Count).End(-4159).Column 'xlToLeft=-4159
End If
With .cells.Font
.Name = "Calibri"
.Size = 12
End With
With .range(.cells(1,1),.cells(1,piNumColumns))
.Font.Size = 10
With .Interior
.Color = RGB(225,225,225)
End With
End With
.range(psActiveCell).select
'AutoFilter
.Application.Selection.AutoFilter
'best-fit columns
.cells.EntireColumn.AutoFit
If piMaxWidth > 0 Then
For nCol = 1 To piNumColumns
'if any column widths > piMaxWidth, Wrap Text
If .Columns(nCol).ColumnWidth > 60 Then
.Columns(nCol).ColumnWidth = 60
.Columns(nCol).WrapText = True
bWrap = True
End If
Next nCol
End If
If bWrap <> False Then
.cells.EntireRow.AutoFit
End If
If pRETURNLastRow > 0 And piNumColumns > 0 Then
'xlDiagonalDown 5
'xlDiagonalUp 6
'xlEdgeLeft 7
'xlEdgeTop 8
'xlEdgeBottom 9
'xlEdgeRight 10
'xlInsideVertical 11
'xlInsideHorizontal 12
With .range(.cells(1,1),.cells(pRETURNLastRow,piNumColumns))
For i = 7 To 12
With .Borders(i)
.LineStyle = 1 'xlContinuous
.Color = RGB(150,150,150)
.Weight = 1 'xlHairline
End With
Next i
' .VerticalAlignment = -4108 'xlCenter
.VerticalAlignment = -4160 'xlVAlignTop
End With
End If
'FreezePanes
.Application.ActiveWindow.FreezePanes = True
End With
End Sub
'-------------------------------------------------------------------------------
' GetVerifySheetname
'-------------------------------------------------------------------------------
Function GetVerifySheetname(pOWb As Object _
,psSheetname As String _
,Optional pReturnTries As Integer _
) As String
'210814 strive4peace
'Return a unique sheet name with 31 characters from a name 30 characters
'if = "" then nothing works -- so don't rename
GetVerifySheetname = ""
On Error Resume Next
'this will work from 1 to 9 copies
Dim sSheetname As String _
,sTest As String
GetVerifySheetname = psSheetname
sSheetname = psSheetname 'assume its ok
pReturnTries = 0 'name didn't get modified
'if name duplicated, add 1-9 to end
'name is 30 characters
'sheet name limit is 31 characters
For pReturnTries = 0 To 8
GetVerifySheetname = sSheetname
'if name is already there, this won't be error
sTest = pOWb.Sheets(sSheetname).Name
If Err.Number <> 0 Then
'this name is ok! Doesn't exist
GoTo Proc_Exit
End If
'try next number
sSheetname = psSheetname & (pReturnTries + 1)
Next pReturnTries
'use letters of alphabet
'if name duplicated, add A-Z to end
For pReturnTries = 10 To 36
GetVerifySheetname = sSheetname '1st test is from numbers
sTest = pOWb.Sheets(sSheetname).Name
If Err.Number <> 0 Then
'name ok
GoTo Proc_Exit
End If
'try next letter. after Z is [ but it won't get tested
sSheetname = psSheetname & Chr(65 - 10 + pReturnTries + 1)
Next pReturnTries
'nothing works -- so don't rename
GetVerifySheetname = ""
Proc_Exit:
On Error Resume Next
Exit Function
End Function
Function LoopRecordsToCells(rsData As Object,oWs As Object) As Long
Dim nRow As Long _
,iCol As Integer _
,iFields As Integer _
,vValues As Variant
nRow = 1 'label row
On Error GoTo Proc_Err
Dim sFieldname As String
With rsData
iFields = .Fields.Count
Do While Not .EOF
nRow = nRow + 1
For iCol = 1 To iFields
sFieldname = .Fields(iCol - 1).Name
If Not IsNull(.Fields(sFieldname).Value) Then
If .Fields(sFieldname).Type = 101 Then 'attachment
Set rs = rsData.Fields(sFieldname).Value
If rs.RecordCount > 0 Then
oWs.cells(nRow,iCol).Value = rs.RecordCount
End If
rs.Close
ElseIf .Fields(sFieldname).Type > 101 Then 'MV
Set rs = rsData.Fields(sFieldname).Value
vValues = Null
Do While Not rs.EOF
vValues = (vValues + "; ") & rs!Value.Value
rs.MoveNext
Loop
rs.Close
If Not IsNull(vValues) Then
oWs.cells(nRow,iCol).Value = vValues
End If
Else
oWs.cells(nRow,iCol).Value = .Fields(sFieldname).Value
End If
End If
Next iCol
.MoveNext
Loop
End With 'rsData
LoopRecordsToCells = nRow
Proc_Exit:
On Error Resume Next
Exit Function ' sub
Proc_Err:
MsgBox Err.Description _
,, "ERROR " & Err.Number _
& " LoopRecordsToCells"
Resume Proc_Exit
Resume
End Function
'*************** Code End *******************************************************
Keywords and comments in code were colored with this free
Color Code add-in
Goto Top
Download
Click
HERE
to download the zipped BAS file containing the code above to document database tables to Excel.
(9 kb, unzips to a module BAS file)
License
This code may be used freely, but you may not sell it in whole or in part.
You may include it in applications you develop for others.
You must have rights and permission to see this information to run this code.
Analyzer
For more extensive documentation, get the free Analyzer here:
http://msaccessgurus.com/tool/Analyzer.htm
Goto Top
Goto Top
Backstory
I wrote this to see what's in a sample database that I'm using for a presentation.
After writing for myself, I saw how it could be useful for others too.
Goto Top
Share with others
here's the link for this page in case you want to copy it:
http://msaccessgurus.com/VBA/Code/Document_Tables2Excel.htm
Share your comments
Email me at info@msAccessGurus.com.
I love hearing about what you're doing with Access!
Are you looking for help with your application?
Let's connect and do it together.
I teach you how to do it yourself.
And as needed, while we build somothing great together,
I'll pull in code and features from my vast libraries,
cutting out lots of development time.
I'm happy to help you!
I like working with people who want to do it themself,
and just need someone to guide past the obstacles
and teach better ways.
For training and programming, email me at training@msAccessGurus.com
I look forward to hearing from you ~
~ crystal
Goto Top
