pdsheep
02-06-2017, 02:14 PM
I have a folder with several hundred files of data that was exported from another program to Excel files. There's a Main spreadsheet and then individual workbooks that have extra data that corresponds to a specific row in the Main. Column A in Main has a numerical primary key for each row and each of those individual files is named with that primary key (so: "1," "2," "3," etc.). I'm trying to import all of those individual files into the Main workbook as new worksheets. Then I need to copy the data from each worksheet and paste it into the corresponding row in the Main sheet. The data in those individual sheets is in multiple rows in column A, so it needs to be transposed when pasted in Main.
I've cobbled together a couple of macros (below) that work, but the file order isn't retained as the files are imported as new sheets. Unfortunately instead of adding file 1 as sheet 2, file 2 as sheet 3, file 3 as sheet 4, etc., it adds them as file 1 as sheet 2, file 10 as sheet 3, file 100 as sheet 4, and so on.
Any help is greatly appreciated!
Sub AppendWorksheets()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "[path]"
fileName = Dir(directory & "*.xl??")
Do While fileName <> "Main.xlsx"
Workbooks.Open (directory & fileName)
For Each sheet In Workbooks(fileName).Worksheets
total = Workbooks("Main.xlsx").Worksheets.Count
Workbooks(fileName).Worksheets(sheet.Name).Copy _
after:=Workbooks("Main.xlsx").Worksheets(total)
Next sheet
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub CopyDataToMain()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim CopyRng As Range
Dim LastRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set DestSh = Sheet1
Set sh = Sheet1
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
LastRow = DestSh.Cells(Rows.Count, 5).End(xlUp).Row
Set CopyRng = sh.Range("A1:A30")
CopyRng.Copy
DestSh.Cells(LastRow + 1, 5).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
End If
Next
Application.Goto DestSh.Cells(1)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I've cobbled together a couple of macros (below) that work, but the file order isn't retained as the files are imported as new sheets. Unfortunately instead of adding file 1 as sheet 2, file 2 as sheet 3, file 3 as sheet 4, etc., it adds them as file 1 as sheet 2, file 10 as sheet 3, file 100 as sheet 4, and so on.
Any help is greatly appreciated!
Sub AppendWorksheets()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "[path]"
fileName = Dir(directory & "*.xl??")
Do While fileName <> "Main.xlsx"
Workbooks.Open (directory & fileName)
For Each sheet In Workbooks(fileName).Worksheets
total = Workbooks("Main.xlsx").Worksheets.Count
Workbooks(fileName).Worksheets(sheet.Name).Copy _
after:=Workbooks("Main.xlsx").Worksheets(total)
Next sheet
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub CopyDataToMain()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim CopyRng As Range
Dim LastRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set DestSh = Sheet1
Set sh = Sheet1
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
LastRow = DestSh.Cells(Rows.Count, 5).End(xlUp).Row
Set CopyRng = sh.Range("A1:A30")
CopyRng.Copy
DestSh.Cells(LastRow + 1, 5).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
End If
Next
Application.Goto DestSh.Cells(1)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub