Combine VBA scripts to increase automation from SAP to Excel to Access

A

audan2009

New Member
Joined
Aug 14, 2013
Messages
38
Hello all,

So, I have to export about 7 reports from SAP varying in size, lengths and widths. I slammed together the following code to clean the excel sheets.

I'd like the code to be able to open all the excel workbooks (saved as .csv from SAP), run the code, save the workbooks as XLSX with a specific name. Then run my Access Script to import them in to Access.

I'm open to all ideas to make this process better.

So here is the code that cleans the excel. The only problem with it is that sometimes SAP prints out a header so I have to delete may be about the first 15 rows until the actual column headings. It varies. I manually do that before running the script. Then save it manually, then open the next workbook and do it again, etc.

Cleaning Code:

Code: 
Sub Sample()
‘combine columns
Application.DisplayAlerts = False
    Dim LastRow As Long
    Dim Ws As Worksheet
    For Each Ws In Worksheets
    LastRow = Ws.Range("A" & Ws.Rows.Count).End(xlUp).Row
    Ws.Range("AA1:AA" & LastRow).Formula = "=a1&b1&c1&d1&e1&f1&g1&h1&i1&j1&k1&l1&m1&n1&o1&p1&q1&r1&s1&t1&u1&v1&w1&x1&y1&z1"
  Next Ws
‘paste values to new worksheet and delete old sheets
  Columns("AA:AA").Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Worksheets(1).Delete
    'Sheets("proc 08-15-13").Select
    'Application.CutCopyMode = False
    'ActiveWindow.SelectedSheets.Delete
 
    For Each Ws In Worksheets
 
        Ws.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(Array(1, 1), Array(2, 2), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12 _
        , 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), _
        Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array( _
        25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), _
        Array(32, 1), Array(33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array( _
        38, 1), Array(39, 1), Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), _
        Array(45, 1), Array(46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array( _
        51, 1), Array(52, 1), Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), _
        Array(58, 1), Array(59, 1), Array(60, 1), Array(61, 1), Array(62, 1), Array(63, 1), Array( _
        64, 1), Array(65, 1), Array(66, 1), Array(67, 1), Array(68, 1), Array(69, 1), Array(70, 1), _
        Array(71, 1), Array(72, 1), Array(73, 1)), TrailingMinusNumbers:=True
     Next Ws
'clean pages
Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$BZ$70000").AutoFilter Field:=2, Criteria1:= _
        "=Material", Operator:=xlOr, Criteria2:="="
    Range("A60").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.EntireRow.Delete
    ActiveSheet.Range("$A$1:$BZ$300000").AutoFilter Field:=2
    ActiveSheet.Range("$A$1:$BZ$300000").AutoFilter Field:=3, Criteria1:="="
    Range("A2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.EntireRow.Delete
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    ActiveSheet.Range("$A$1:$BZ$300000").AutoFilter Field:=2
'trim column headings
[I]Dim arrData() As Variant[/I]
[I]Dim arrReturnData() As Variant[/I]
[I]Dim rng As Excel.Range[/I]
[I]Dim lRows As Long[/I]
[I]Dim lCols As Long[/I]
[I]Dim i As Long, j As Long[/I]
 
[I]  lRows = Selection.Rows.count[/I]
[I]  lCols = Selection.Columns.count[/I]
 
[I]  ReDim arrData(1 To lRows, 1 To lCols)[/I]
[I]  ReDim arrReturnData(1 To lRows, 1 To lCols)[/I]
 
[I]  Set rng = Selection[/I]
[I]  arrData = rng.value[/I]
 
[I]  For j = 1 To lCols[/I]
[I]    For i = 1 To lRows[/I]
[I]      arrReturnData(i, j) = Trim(arrData(i, j))[/I]
[I]    Next i[/I]
[I]  Next j[/I]
 
[I]  rng.value = arrReturnData[/I]
 
[I]  Set rng = Nothing[/I]End Sub

This is the script I run in Access to import:

Code: 
Option Compare Database
Sub e2a()
Dim strSaveName As String
strSaveName = "C:\Users\username\Desktop\ITP\Current Data\awarded.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "Awarded", strSaveName, True, "Sheet1$"
strSaveName = "C:\Users\username\Desktop\ITP\Current Data\sales.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "Sales", strSaveName, True, "Sheet1$"
strSaveName = "C:\Users\username\Desktop\ITP\Current Data\inventory.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "Inventory", strSaveName, True, "Sheet1$"
strSaveName = "C:\Users\username\Desktop\ITP\Current Data\mara.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "MARA", strSaveName, True, "Sheet1$"
strSaveName = "C:\Users\username\Desktop\ITP\Current Data\unawarded.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "Unawarded", strSaveName, True, "Sheet1$"
strSaveName = "C:\Users\username\Desktop\ITP\Current Data\repair.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "Repair", strSaveName, True, "repiar$"
strSaveName = "C:\Users\username\Desktop\ITP\Current Data\ID.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "ID", strSaveName, True, "Sheet1$"
strSaveName = "C:\Users\username\Desktop\ITP\Current Data\DD.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "DD", strSaveName, True, "Sheet1$"

End Sub
 
Last edited:

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
Sort by date Sort by votes
Where do you want to combine them? Access or Excel?
 
Upvote 0
My #1 preference is that each cleaned workbook ends up in Access as a individual table. I don't really care how that happens such as:

1) A script combines all the spreadsheets in to 1 workbook, then Access imports each sheet.
2) Script opens each excel workbook and cleans them and saves them indvidual, then Access imports each workbook.

or something more mindblowing.
 
Upvote 0
I just solved the problem of having to manually delete the first 15ish rows with:

Code: 
Const colA      As Long = 1
Dim lngRow      As Long
Dim lngLastRow  As Long
lngLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
lngRow = 1
lngLastRow = 50
Do While lngRow <= lngLastRow
    If Left(Cells(lngRow, colA), 1) <> "|" Then
        Cells(lngRow, 1).EntireRow.Delete
        lngLastRow = lngLastRow - 1
        Else: lngRow = lngRow + 1
    End If
    Loop
 
Upvote 0
What I'm asking is where you want to comine the 2 subs.

By the way, have you considered cutting out the 'middle man' Excel an importing directly to Access?

There's nothing in you Excel code that can't be done in Access.
 
Upvote 0
Yes, I have considered that but I'm not confident enough in my skills to do that. Really, I've been slightly modifying code that I google to get it to work.

That'd be awesome to run the script in Access and it clean up all the excel stuff and imported the tables :)
 
Upvote 0
This seems to be really close aside from the fname ending with .xlsx. It'd be .csv and save as .xlsx.

I ran it and it cleaned up the 1st workbook but couldn't save it. I'm assuming this part is incomplete:

Code: 
wbk.saveas savfolder & fname
  wbk.close9.  fname = dir   ' get next file name

Code: 
srcfolder = ' your path with trailing \
fname = dir(srcfolder & "*.xlsx")  ' get first file name to match pattern
do until len(fname) = 0  ' stop loop when no more files found
set wbk = workbooks.open(srcfolder & fname)
 set sht = wbk.sheets("sheet1")  ' set sheet object, change sheet name to suit, or use index
 ' do all processing with workbook
  wbk.saveas savfolder & fname
  wbk.close9.  fname = dir   ' get next file name
loop
 
Upvote 0
This seems to be really close aside from the fname ending with .xlsx. It'd be .csv and save as .xlsx.

I ran it and it cleaned up the 1st workbook but couldn't save it. I'm assuming this part is incomplete:

Code: 
wbk.saveas savfolder & fname
  wbk.close9.  fname = dir   ' get next file name

Code: 
srcfolder = ' your path with trailing \
fname = dir(srcfolder & "*.xlsx")  ' get first file name to match pattern
do until len(fname) = 0  ' stop loop when no more files found
set wbk = workbooks.open(srcfolder & fname)
 set sht = wbk.sheets("sheet1")  ' set sheet object, change sheet name to suit, or use index
 ' do all processing with workbook
  wbk.saveas savfolder & fname
  wbk.close9.  fname = dir   ' get next file name
loop
 
Upvote 0
This runs through all the sheets, runs the script but it doesn't look like its saving the changes!

So close!


Code: 
Sub test()
srcfolder = "C:\Users\username\Desktop\ITP\Test\Raw\"
fname = Dir(srcfolder & "*.csv")  ' get first file name to match pattern

Do Until Len(fname) = 0  ' stop loop when no more files found
Set wbk = Workbooks.Open(srcfolder & fname)
 Set sht = Worksheets(1) ' set sheet object, change sheet name to suit, or use index
 ' do all processing with workbook
'delete rows until pipe
Const colA      As Long = 1
Dim lngRow      As Long
Dim lngLastRow  As Long
lngLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
lngRow = 1
lngLastRow = 50
Do While lngRow <= lngLastRow
    If (Left(Cells(lngRow, colA), 3) <> "| M" And Left(Cells(lngRow, colA), 3) <> "| 0") And (Left(Cells(lngRow, colA), 2) <> "|M" And Left(Cells(lngRow, colA), 2) <> "|0") Then
        Cells(lngRow, 1).EntireRow.Delete
        lngLastRow = lngLastRow - 1
        Else: lngRow = lngRow + 1
    End If
    Loop
'combine columns
Application.DisplayAlerts = False
    Dim LastRow As Long
    Dim Ws As Worksheet
    For Each Ws In Worksheets
    LastRow = Ws.Range("A" & Ws.Rows.Count).End(xlUp).Row
    Ws.Range("AA1:AA" & LastRow).Formula = "=a1&b1&c1&d1&e1&f1&g1&h1&i1&j1&k1&l1&m1&n1&o1&p1&q1&r1&s1&t1&u1&v1&w1&x1&y1&z1"
  Next Ws
'paste values to new worksheet and delete old sheets
  Columns("AA:AA").Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Worksheets(1).Delete
    'Sheets("proc 08-15-13").Select
    'Application.CutCopyMode = False
    'ActiveWindow.SelectedSheets.Delete
    For Each Ws In Worksheets
        Ws.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12 _
        , 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), _
        Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array( _
        25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), _
        Array(32, 1), Array(33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array( _
        38, 1), Array(39, 1), Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), _
        Array(45, 1), Array(46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array( _
        51, 1), Array(52, 1), Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), _
        Array(58, 1), Array(59, 1), Array(60, 1), Array(61, 1), Array(62, 1), Array(63, 1), Array( _
        64, 1), Array(65, 1), Array(66, 1), Array(67, 1), Array(68, 1), Array(69, 1), Array(70, 1), _
        Array(71, 1), Array(72, 1), Array(73, 1)), TrailingMinusNumbers:=True
     Next Ws
'clean pages
Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$BZ$70000").AutoFilter Field:=2, Criteria1:= _
        "=Material", Operator:=xlOr, Criteria2:="="
    Range("A60").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.EntireRow.Delete
    ActiveSheet.Range("$A$1:$BZ$300000").AutoFilter Field:=2
    ActiveSheet.Range("$A$1:$BZ$300000").AutoFilter Field:=3, Criteria1:="="
    Range("A2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.EntireRow.Delete
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    ActiveSheet.Range("$A$1:$BZ$300000").AutoFilter Field:=2
'trim column headings
Dim arrData() As Variant
Dim arrReturnData() As Variant
Dim rng As Excel.Range
Dim lRows As Long
Dim lCols As Long
Dim i As Long, j As Long
  lRows = Selection.Rows.Count
  lCols = Selection.Columns.Count
  ReDim arrData(1 To lRows, 1 To lCols)
  ReDim arrReturnData(1 To lRows, 1 To lCols)
  Set rng = Selection
  arrData = rng.Value
  For j = 1 To lCols
    For i = 1 To lRows
      arrReturnData(i, j) = Trim(arrData(i, j))
    Next i
  Next j
  rng.Value = arrReturnData
  Set rng = Nothing
    wbk.SaveAs savFolder & fname
  wbk.Close
  fname = Dir 'get next file name
  
Loop
End Sub
 
Upvote 0
I got this to work for the most part! Its extremely dirty.

Once it starts to export to excel, it won't save the formating that I want. Its very annoying. I'm also wondering in the section on "'clean pages" if there is a better way? Basically I need to filter out any blanks rows, rows that contain "-----", rows that contain the same data as the headers.... this is SAP repeating pages. The macro I recorded and repeated doesnt work for every single page... it may be deleting more or less on some.

Code: 
Option Compare Database
Sub e2a()
 Dim strWorksheet As String
 Dim strWorkSheetPath As String
 Dim appExcel As Excel.Application
 
 Dim sht As Excel.Worksheet
 Dim wkb As Excel.Workbook
 Dim Rng As Excel.Range
 Dim strTable As String
 Dim strRange As String
 Dim strSaveName As String
 Dim strPrompt As String
 Dim strTitle As String
 Dim strDefault As String
Set appExcel = CreateObject("Excel.Application")
appExcel.Application.Visible = True
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "C:\Users\username\Desktop\ITP\Current Data\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(FileName:=strDir & strFile, Local:=True)
   With wb
        .SaveAs Replace(wb.FullName, ".csv", ".xlsx"), 51 'UPDATE:
        .Close True
    End With
    Set wb = Nothing
strFile = Dir
Loop
'reopen and run
Dim wbk As Workbook
Dim srcfolder As String, fname As String
srcfolder = "C:\Users\username\Desktop\ITP\Current Data\"
fname = Dir(srcfolder & "*.xlsx")  ' get first file name to match pattern
Do Until Len(fname) = 0  ' stop loop when no more files found
Set wbk = Workbooks.Open(FileName:=srcfolder & fname, Local:=True)
 Set shtsave = Worksheets(1) ' set sheet object, change sheet name to suit, or use index
 ' do all processing with workbook
'delete rows until pipe
Const colA      As Long = 1
Dim lngRow      As Long
Dim lngLastRow  As Long
lngLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
lngRow = 1
lngLastRow = 50
Do While lngRow <= lngLastRow
    If (Left(Cells(lngRow, colA), 3) <> "| M" And Left(Cells(lngRow, colA), 3) <> "| 0") And (Left(Cells(lngRow, colA), 2) <> "|M" And Left(Cells(lngRow, colA), 2) <> "|0") And (Left(Cells(lngRow, colA), 2) <> "|Z" And Left(Cells(lngRow, colA), 2) <> "|0") Then
        Cells(lngRow, 1).EntireRow.Delete
        lngLastRow = lngLastRow - 1
        Else: lngRow = lngRow + 1
    End If
    Loop
'combine columns
    Dim LastRow As Long
    Dim Ws As Worksheet
    For Each Ws In Worksheets
    LastRow = Ws.Range("A" & Ws.Rows.Count).End(xlUp).Row
    Ws.Range("AA1:AA" & LastRow).Formula = "=a1&b1&c1&d1&e1&f1&g1&h1&i1&j1&k1&l1&m1&n1&o1&p1&q1&r1&s1&t1&u1&v1&w1&x1&y1&z1"
  Next Ws
'paste values to new worksheet and delete old sheets
  Columns("AA:AA").Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    DoCmd.SetWarnings False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Worksheets(1).Delete
    'Sheets("proc 08-15-13").Select
    'Application.CutCopyMode = False
    'ActiveWindow.SelectedSheets.Delete
    For Each Ws In Worksheets
        Ws.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12 _
        , 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), _
        Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array( _
        25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), _
        Array(32, 1), Array(33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array( _
        38, 1), Array(39, 1), Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), _
        Array(45, 1), Array(46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array( _
        51, 1), Array(52, 1), Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), _
        Array(58, 1), Array(59, 1), Array(60, 1), Array(61, 1), Array(62, 1), Array(63, 1), Array( _
        64, 1), Array(65, 1), Array(66, 1), Array(67, 1), Array(68, 1), Array(69, 1), Array(70, 1), _
        Array(71, 1), Array(72, 1), Array(73, 1)), TrailingMinusNumbers:=True
     Next Ws
'clean pages
Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$BZ$700000").AutoFilter Field:=2, Criteria1:= _
        "=Material", Operator:=xlOr, Criteria2:="="
    Range("A60").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.EntireRow.Delete
    ActiveSheet.Range("$A$1:$BZ$700000").AutoFilter Field:=2
    ActiveSheet.Range("$A$1:$BZ$700000").AutoFilter Field:=3, Criteria1:="="
    Range("A2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.EntireRow.Delete
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    ActiveSheet.Range("$A$1:$BZ$300000").AutoFilter Field:=2
'trim column headings
 Dim a(), c&, cs&, r&, rs&, Rng2 As Range
  Set Rng2 = Range("A1:DD70000")
  a() = Rng2.Value
  rs = UBound(a, 1)
  cs = UBound(a, 2)
  For r = 1 To rs
    For c = 1 To cs
      If VarType(a(r, c)) = vbString Then a(r, c) = Trim(a(r, c))
    Next
  Next
  Rng2.Value = a()
    
With wbk
    .Save
    .Close True
End With
Set wbk = Nothing
fname = Dir
   
Loop

Dim strSaveNameForExport As String
DoCmd.DeleteObject acTable, "Awarded"
DoCmd.DeleteObject acTable, "Sales"
DoCmd.DeleteObject acTable, "Inventory"
DoCmd.DeleteObject acTable, "MARA"
DoCmd.DeleteObject acTable, "Unawarded"
DoCmd.DeleteObject acTable, "DD"
DoCmd.DeleteObject acTable, "ID"
DoCmd.DeleteObject acTable, "Repair"
strSaveNameForExport = "C:\Users\username\Desktop\ITP\Current Data\table1.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "table1", strSaveNameForExport, True, "Sheet1$"
strSaveNameForExport = "C:\Users\username\Desktop\ITP\Current Data\table2.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "table2", strSaveNameForExport, True, "Sheet1$"
strSaveNameForExport = "C:\Users\username\Desktop\ITP\Current Data\table3.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "table3", strSaveNameForExport, True, "Sheet1$"
strSaveNameForExport = "C:\Users\username\Desktop\ITP\Current Data\table4.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "table4", strSaveNameForExport, True, "Sheet1$"
strSaveNameForExport = "C:\Users\username\Desktop\ITP\Current Data\table5.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "table5", strSaveNameForExport, True, "Sheet1$"
strSaveNameForExport = "C:\Users\username\Desktop\ITP\Current Data\table6.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "table6", strSaveNameForExport, True, "Sheet1$"
strSaveNameForExport = "C:\Users\username\Desktop\ITP\Current Data\table7.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "table7", strSaveNameForExport, True, "Sheet1$"
strSaveNameForExport = "C:\Users\username\Desktop\ITP\Current Data\Repair\table8.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "table8", strSaveNameForExport, True, "Sheet1$"
DoCmd.DeleteObject acTable, "Sheet1$_ImportErrors"
DoCmd.DeleteObject acTable, "Sheet1$_ImportErrors1"
 
 'start export to excel
 
 strTable = "Sheet1"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "Sheet1"
 strTable1 = "Sheet2"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "Sheet2"
 
 strTable2 = "Sheet3"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "Sheet3"
 
 strTable3 = "Sheet4"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "Sheet4"
 
 strTable4 = "Sheet5"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "Sheet5"
 
 strTable5 = "Sheet6"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "Sheet6"
 
 strTable6 = "Sheet7"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "Sheet7"
 
 strWorkSheetPath = GetWorksheetsPath
 strWorksheet = "SPIDER Results"
 strSaveName = strWorkSheetPath & strWorksheet & ".xlsx"
 Debug.Print "Worksheet save name" & strSaveName
 
 On Error Resume Next
 
 Kill strSaveName
 
 
 
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel12Xml, _
    TableName:=strTable, FileName:=strSaveName, _
    hasfieldnames:=True
    
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel12Xml, _
    TableName:=strTable1, FileName:=strSaveName, _
    hasfieldnames:=True
    
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel12Xml, _
    TableName:=strTable2, FileName:=strSaveName, _
    hasfieldnames:=True
    
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel12Xml, _
    TableName:=strTable3, FileName:=strSaveName, _
    hasfieldnames:=True
    
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel12Xml, _
    TableName:=strTable4, FileName:=strSaveName, _
    hasfieldnames:=True
    
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel12Xml, _
    TableName:=strTable5, FileName:=strSaveName, _
    hasfieldnames:=True
    
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel12Xml, _
    TableName:=strTable6, FileName:=strSaveName, _
    hasfieldnames:=True
    
Set appExcel = GetObject(, "Excel.Application")
appExcel.Workbooks.Open (strSaveName)
Set wkb = appExcel.ActiveWorkbook
Set sht = appExcel.ActiveSheet
Set sht1 = appExcel.Worksheets(2)
Set sht2 = appExcel.Worksheets(3)
Set sht3 = appExcel.Worksheets(4)
Set sht4 = appExcel.Worksheets(5)
Set sht5 = appExcel.Worksheets(6)
Set sht6 = appExcel.Worksheets(7)

sht.Activate
With sht 'Sheet1
    
 appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Columns("A:I").ColumnWidth = 14
    appExcel.Columns("J:J").ColumnWidth = 20
    appExcel.Columns("K:K").ColumnWidth = 9
    appExcel.Columns("L:O").ColumnWidth = 20
    appExcel.Columns("P:P").ColumnWidth = 13
    appExcel.Columns("Q:T").ColumnWidth = 12
    appExcel.Columns("A:W").HorizontalAlignment = xlCenter
    appExcel.Columns("A:W").VerticalAlignment = xlCenter
End With
sht1.Activate
With sht1 'Sheet2
    
   appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Columns("A:I").ColumnWidth = 14
    appExcel.Columns("A:I").HorizontalAlignment = xlCenter
    appExcel.Columns("A:I").VerticalAlignment = xlCenter
End With
sht2.Activate
With sht2 'Sheet3
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Columns("A:D").ColumnWidth = 14
    appExcel.Columns("E:E").ColumnWidth = 16
    appExcel.Columns("F:F").ColumnWidth = 12
    appExcel.Columns("G:G").ColumnWidth = 20.57
    appExcel.Columns("H:H").ColumnWidth = 9
    appExcel.Columns("I:I").ColumnWidth = 15
    appExcel.Columns("J:Q").ColumnWidth = 14
    appExcel.Columns("A:Q").HorizontalAlignment = xlCenter
    appExcel.Columns("A:Q").VerticalAlignment = xlCenter
End With
sht3.Activate
With sht3 'Organic Repair
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Columns("A:B").ColumnWidth = 14
    appExcel.Columns("C:E").ColumnWidth = 10.5
    appExcel.Columns("F:F").ColumnWidth = 20.57
    appExcel.Columns("G:J").ColumnWidth = 13
    appExcel.Columns("G:J").ColumnWidth = 13
    appExcel.Columns("K:K").ColumnWidth = 20.57
    appExcel.Columns("L:M").ColumnWidth = 13
    appExcel.Columns("A:M").HorizontalAlignment = xlCenter
    appExcel.Columns("A:M").VerticalAlignment = xlCenter
End With
sht4.Activate
With sht4 'Awarded
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Columns("A:F").ColumnWidth = 14
    appExcel.Columns("G:H").ColumnWidth = 24
    appExcel.Columns("I:J").ColumnWidth = 9
    appExcel.Columns("K:N").ColumnWidth = 21
    appExcel.Columns("O:P").ColumnWidth = 13
    appExcel.Columns("Q:S").ColumnWidth = 12
    appExcel.Columns("T:U").ColumnWidth = 21
    appExcel.Columns("V:W").ColumnWidth = 12.5
    appExcel.Columns("X:Y").ColumnWidth = 11.5
    appExcel.Columns("Z:AF").ColumnWidth = 21
    appExcel.Columns("AG:AI").ColumnWidth = 14
    appExcel.Columns("AJ:AN").ColumnWidth = 10
    appExcel.Columns("AO:AQ").ColumnWidth = 14
    appExcel.Columns("AR:AR").ColumnWidth = 18
    appExcel.Columns("A:AQ").HorizontalAlignment = xlCenter
    appExcel.Columns("A:AQ").VerticalAlignment = xlCenter
End With
sht5.Activate
With sht5 'Unawarded
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Columns("A:E").ColumnWidth = 14
    appExcel.Columns("F:G").ColumnWidth = 11
    appExcel.Columns("H:I").ColumnWidth = 12
    appExcel.Columns("I:I").ColumnWidth = 9.5
    appExcel.Columns("J:J").ColumnWidth = 21
    appExcel.Columns("K:K").ColumnWidth = 27
    appExcel.Columns("L:L").ColumnWidth = 9.5
    appExcel.Columns("M:M").ColumnWidth = 18
    appExcel.Columns("N:N").ColumnWidth = 19
    appExcel.Columns("O:Q").ColumnWidth = 9.5
    appExcel.Columns("R:R").ColumnWidth = 21
    appExcel.Columns("S:S").ColumnWidth = 9.5
    appExcel.Columns("T:U").ColumnWidth = 21
    appExcel.Columns("V:AA").ColumnWidth = 14
    appExcel.Columns("A:AA").HorizontalAlignment = xlCenter
    appExcel.Columns("A:AA").VerticalAlignment = xlCenter
End With
sht6.Activate
With sht6 'Sheet7
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Columns("A:G").ColumnWidth = 15
    appExcel.Columns("A:G").HorizontalAlignment = xlCenter
    appExcel.Columns("A:G").VerticalAlignment = xlCenter
End With
sht.Name = "Sheet1"
sht1.Name = "Sheet2"
sht2.Name = "Sheet3"
sht3.Name = "Sheet4"
sht4.Name = "Sheet5"
sht5.Name = "Sheet6"
sht6.Name = "Sheet7"

appExcel.Application.Visible = True
strPrompt = _
    "Enter file name and path for saving worksheet"
strTitle = "File Name"
strDefault = strSaveName
strSaveName = InputBox(prompt:=strPrompt, _
    Title:=strTitle, Default:=strDefault)
    
wkb.SaveAs FileName:=strSaveName
appExcel.Visible = True
 
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

JeffGrant
  • Solved
VBA Code used twice, keeps table formatting on one sheet, but not on the other
Replies
4
Views
241
smozgur
smozgur
L
  • Solved
VBA SaveAs
Replies
3
Views
268
Joe4
Joe4
C
  • Solved
VBA Print to PDF Macro (with specific file name and type)
Replies
2
Views
288
CHOPDOG
C
I
  • Solved
Formate date when transfering from worksheet to worksheet
Replies
4
Views
327
ipbr21054
I
I
  • Question
Inoice number not being saved in cell
Replies
6
Views
301
ipbr21054
I

Forum statistics

Threads
1,214,979
Messages
6,122,552
Members
449,088
Latest member
davidcom

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top