PianoMan5
07-12-2012, 12:49 PM
I've come a long way in the week I've been doing my macros! :whistle:
Anyways, please review the code below as sometimes it works perfectly then when I rerun it again, it messes up...I'm getting issues with blanks in between "pastes" and also trying to remove the headers (I'm trying it by doing a filter).
Can you please help?! :help
Sub Combine_Worksheets()
'This will copy data from all sheets of the selected workbooks
'To a sheet named 'Data' in the sheet in which the macro is run from
Dim pasterow As Integer
Dim LastRow As Long
Dim LastCol As Long
Dim MsgAnswer As VbMsgBoxResult
Dim mainsheetname As String
Dim HeaderRow As Integer
mainsheetname = ActiveWorkbook.Name
MsgAnswer = MsgBox("Please select all excel workbooks to combine _
(use keyboard key CTL to select all) then click Open." _
& vbNewLine & vbNewLine & "*Ensure the headers for each workbook/worksheet is the EXACT same as " _
& "otherwise the consolidated " & "data will be skewed.", vbOKCancel, "Workbook Locator")
If MsgAnswer = vbCancel Then Exit Sub
filestoopen = Application.GetOpenFilename(MultiSelect:=True)
If Not ActiveSheet.Name = "Data" Then ActiveSheet.Name = "Data"
Worksheets("Data").Select
'open workbooks
For Each w In filestoopen
Application.DisplayAlerts = False
Workbooks.Open Filename:=w
copysheetname = ActiveWorkbook.Name
'copy and paste sheets
For Each sh In Worksheets
Application.DisplayAlerts = False
sheetnumber = sh.Index
'something = Worksheets(sheetnumber).UsedRange.Rows.Count + 1
If WorksheetFunction.CountA(Cells) > 0 Then
'Searches for the last cell with data and retreives the row and column #s
LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
LastCol = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Range("A1", Cells(LastRow, LastCol)).Copy
End If
Worksheets(sheetnumber).UsedRange.Copy
Workbooks(mainsheetname).Activate
pasterow =Workbooks(mainsheetname).Worksheets("Data").UsedRange _
.Rows.Count + 1
If pasterow = 2 Then pasterow = 1
Workbooks(mainsheetname).Worksheets("Data").Range("A" & pasterow) _
.Select
ActiveSheet.Paste
Workbooks(copysheetname).Activate
Next sh
Application.DisplayAlerts = False
ActiveWorkbook.Close
Next w
Workbooks(mainsheetname).Worksheets("Data").Activate
Range("A1:AN65000").Select
Selection.Columns.AutoFit
Selection.Rows.AutoFit
Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("A:A").AutoFilter Field:=1, Criteria1:=Range("A1").Value
Rows("3:65000").Delete
Selection.AutoFilter
'Filters for all headers (according to the initial header on row A and deletes them
Application.DisplayAlerts = True
End Sub
Anyways, please review the code below as sometimes it works perfectly then when I rerun it again, it messes up...I'm getting issues with blanks in between "pastes" and also trying to remove the headers (I'm trying it by doing a filter).
Can you please help?! :help
Sub Combine_Worksheets()
'This will copy data from all sheets of the selected workbooks
'To a sheet named 'Data' in the sheet in which the macro is run from
Dim pasterow As Integer
Dim LastRow As Long
Dim LastCol As Long
Dim MsgAnswer As VbMsgBoxResult
Dim mainsheetname As String
Dim HeaderRow As Integer
mainsheetname = ActiveWorkbook.Name
MsgAnswer = MsgBox("Please select all excel workbooks to combine _
(use keyboard key CTL to select all) then click Open." _
& vbNewLine & vbNewLine & "*Ensure the headers for each workbook/worksheet is the EXACT same as " _
& "otherwise the consolidated " & "data will be skewed.", vbOKCancel, "Workbook Locator")
If MsgAnswer = vbCancel Then Exit Sub
filestoopen = Application.GetOpenFilename(MultiSelect:=True)
If Not ActiveSheet.Name = "Data" Then ActiveSheet.Name = "Data"
Worksheets("Data").Select
'open workbooks
For Each w In filestoopen
Application.DisplayAlerts = False
Workbooks.Open Filename:=w
copysheetname = ActiveWorkbook.Name
'copy and paste sheets
For Each sh In Worksheets
Application.DisplayAlerts = False
sheetnumber = sh.Index
'something = Worksheets(sheetnumber).UsedRange.Rows.Count + 1
If WorksheetFunction.CountA(Cells) > 0 Then
'Searches for the last cell with data and retreives the row and column #s
LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
LastCol = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Range("A1", Cells(LastRow, LastCol)).Copy
End If
Worksheets(sheetnumber).UsedRange.Copy
Workbooks(mainsheetname).Activate
pasterow =Workbooks(mainsheetname).Worksheets("Data").UsedRange _
.Rows.Count + 1
If pasterow = 2 Then pasterow = 1
Workbooks(mainsheetname).Worksheets("Data").Range("A" & pasterow) _
.Select
ActiveSheet.Paste
Workbooks(copysheetname).Activate
Next sh
Application.DisplayAlerts = False
ActiveWorkbook.Close
Next w
Workbooks(mainsheetname).Worksheets("Data").Activate
Range("A1:AN65000").Select
Selection.Columns.AutoFit
Selection.Rows.AutoFit
Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("A:A").AutoFilter Field:=1, Criteria1:=Range("A1").Value
Rows("3:65000").Delete
Selection.AutoFilter
'Filters for all headers (according to the initial header on row A and deletes them
Application.DisplayAlerts = True
End Sub