I have here three codes for consolidating workbooks into one workbook in a specific sheet name, but my problem is
consolidating data of one shared workbook then transfer in one specific workbook, without replicating the previos data??
CONSOLIDATE WORKBOOK
Sub CopyAllOpenBooksVer4()
Dim Sh As Worksheet
Dim Wb As Workbook
For Each Wb In Workbooks
If Not Wb.Name = ThisWorkbook.Name Then
For Each Sh In Wb.Worksheets
On Error Resume Next
ConstRng = Sh.Cells.SpecialCells(xlCellTypeConstants, 3).Address
On Error Resume Next
FormRng = Sh.Cells.SpecialCells(xlCellTypeFormulas, 3).Address
If FormRng = "" Then FormRng = ConstRng
If ConstRng = "" Then ConstRng = FormRng
If Not FormRng = "" And Not ConstRng = "" Then
Start = Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Union(Sh.Range(FormRng), Sh.Range(ConstRng)).EntireRow.Copy
Range("A" & Start).PasteSpecial Paste:=xlPasteValues
Range("A" & Start).PasteSpecial Paste:=xlPasteFormats
' PLACE BOOK NAME IN COLUMN X AND SHEET NAME IN COLUMN Y
Range("Z" & Start & ":Z" & Cells.SpecialCells(xlCellTypeLastCell).Row) = Wb.Name
Range("Y" & Start & ":Y" & Cells.SpecialCells(xlCellTypeLastCell).Row) = Sh.Name
FormRng = ""
ConstRng = ""
End If
Next Sh
End If ' WB name not this one
Next Wb
End Sub
<code>
COMBINED INTO ONE WORKBOOK
Option Explicit Public u_sheets As String Sub Consolidate() Dim ws As Worksheet Dim wb As Workbook, NewBook As Workbook Dim scount As Integer Dim NewWS As Worksheet Dim wsSheet As Worksheet Dim i As Integer Dim NextName As String Dim sl As Integer Dim newfilepath As String newfilepath = "" Dim first_only As Boolean first_only = False Call init 'are we doing the first sheet only? If u_sheets = "First Sheet Only" Then first_only = True 'Setup Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False 'Create new workbook for merged sheets newfilepath = ThisWorkbook.Path & "\Merged" 'excel will auto append the appropriate extension (xlsx) Set NewBook = Workbooks.Add NewBook.SaveAs Filename:=newfilepath i = 1 'Loop through each open workbook For Each wb In Workbooks If wb.Name <> ThisWorkbook.Name And wb.Name <> NewBook.Name And Left(wb.Name, 8) <> "PERSONAL" Then Dim x As String 'Get name of this workbook x = JustText(Left(wb.Name, Len(wb.Name) - 4)) 'count sheets in this workbook If first_only Then scount = 1 Else scount = wb.Sheets.Count End If 'Loop through each sheet in Workbook For Each ws In wb.Worksheets 'do some naming conventions Dim xy As String Dim y As String y = JustText(ws.Name) 'strip out all characters from name If scount > 1 Then xy = x + y Else xy = x End If 'check the length of the new name and shorten if needed sl = Len(xy) If sl > 30 Then xy = Right(x, sl - (sl - 30)) End If 'copy worksheet to new workbook ws.Copy After:=NewBook.Worksheets(NewBook.Worksheets.Count) 'rename worksheet NewBook.Worksheets(NewBook.Worksheets.Count).Name = xy If scount = 1 Then Exit For 'break out of loop if we are only doing one sheet Next End If Next 'remove all original worksheets 'NewBook.Worksheets("Sheet1").Delete 'NewBook.Worksheets("Sheet2").Delete 'NewBook.Worksheets("Sheet3").Delete ErrorExit: 'Cleanup Application.DisplayAlerts = True 'turn system alerts back on Application.EnableEvents = True 'turn other macros back on Application.ScreenUpdating = True 'refreshes the screen End Sub Private Function JustText(text_to_clean As String, Optional upper As Boolean = False) 'removes all characters except for letters and numbers 'where 'text_to_clean is the text to clean 'upper boolean will return UPPER case if true; false if omitted 'declare and initialize user variables Dim method As Integer 'choices: '1=remove everything except what is in the leave_these variable '2=leave everything except what is specifically removed from the "leave" section method = 1 Dim leave_these As String 'only used if method=1 leave_these = "A-Za-z0-9" 'if you want to allow a space "A-Za-z0-9 " 'declare and initialize system variables Dim temp As String temp = text_to_clean 'method Select Case method Case 1 'remove everything except what is in the leave_these variable Dim x As String, y As String, z As String, i As Long x = temp For i = 1 To Len(x) y = Mid(x, i, 1) If y Like "[" & leave_these & "]" Then z = z & y Next i temp = z Case 2 'leave everything except characters below 'feel free to comment out the lines for items you do not wish to remove, or add new lines as desired temp = Replace(temp, ",", "") 'remove commas temp = Replace(temp, " ", "") 'remove spaces temp = Replace(temp, "-", "") 'remove dashes temp = Replace(temp, ":", "") 'remove colon temp = Replace(temp, ";", "") 'remove semi-colon End Select If upper Then JustText = UCase(temp) Else JustText = temp End Function Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean On Error Resume Next WorksheetExists = (Sheets(WorksheetName).Name <> "") On Error GoTo 0 End Function Private Sub init() 'initialize all public variables u_sheets = Range("u_sheets") End Sub
</code></pre>
<code>
</code><code>Public Sub ConsolidateSheets() Dim Wb1 As Workbook Dim Wb2 As Workbook Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Dim rng1 As Range Dim rng2 As Range Dim rng3 As Range Dim rngArea As Range Dim lrowSpace As Long Dim lSht As Long Dim lngCalc As Long Dim lngRow As Long Dim lngCol As Long Dim X() Dim bProcessFolder As Boolean Dim bNewSheet As Boolean Dim StrPrefix Dim strFileName As String Dim strFolderName As String 'variant declaration needed for the Shell object to use a default directory Dim strDefaultFolder As Variant bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes) bNewSheet = (MsgBox("Extract all data to a single sheet (Yes)," & vbNewLine & "or a target file sheet for each source sheet (No)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes) If Not bProcessFolder Then If Not bNewSheet Then MsgBox "There isn't much point creating a exact replica of your source file
" Exit Sub End If End If 'set default directory here if needed strDefaultFolder = "C:\temp" 'If the user is collating all the sheets to a single target sheet then the row spacing 'to distinguish between different sheets can be set here lrowSpace = 1 If bProcessFolder Then strFolderName = BrowseForFolder(strDefaultFolder) 'Look for xls, xlsx, xlsm files strFileName = Dir(strFolderName & "\*.xls*") Else strFileName = Application _ .GetOpenFilename("Select file to process (*.xls*), *.xls*") End If Set Wb1 = Workbooks.Add(1) Set ws1 = Wb1.Sheets(1) If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count") 'Turn off screenupdating, events, alerts and set calculation to manual With Application .DisplayAlerts = False .EnableEvents = False .ScreenUpdating = False lngCalc = .Calculation .Calculation = xlCalculationManual End With 'set path outside the loop StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString) Do While Len(strFileName) > 0 'Provide progress status to user Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255) 'Open each workbook in the folder of interest Set Wb2 = Workbooks.Open(StrPrefix & strFileName) If Not bNewSheet Then 'add summary details to first sheet ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count End If For Each ws2 In Wb2.Sheets If bNewSheet Then 'All data to a single sheet 'Skip importing target sheet data if the source sheet is blank Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious) If Not rng2 Is Nothing Then Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious) 'Find the first blank row on the target sheet If Not rng1 Is Nothing Then Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A")) 'Ensure that the row area in the target sheet won't be exceeded If rng3.Rows.Count + rng1.Row < Rows.Count Then 'Copy the data from the used range of each source sheet to the first blank row 'of the target sheet, using the starting column address from the source sheet being copied ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column) Else MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _ "sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name Wb2.Close False Exit Do End If 'colour the first of any spacer rows If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen Else 'target sheet is empty so copy to first row ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column) End If End If Else 'new target sheet for each source sheet ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count) 'Remove any links in our target sheet With Wb1.Sheets(Wb1.Sheets.Count).Cells .Copy .PasteSpecial xlPasteValues End With On Error Resume Next Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name 'sheet name already exists in target workbook If Err.Number <> 0 Then 'Add a number to the sheet name till a unique name is derived Do lSht = lSht + 1 Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht) Loop While Not ws3 Is Nothing lSht = 0 End If On Error GoTo 0 End If Next ws2 'Close the opened workbook Wb2.Close False 'Check whether to force a DO loop exit if processing a single file If bProcessFolder = False Then Exit Do strFileName = Dir Loop 'Remove any links if the user has used a target sheet If bNewSheet Then With ws1.UsedRange .Copy .Cells(1).PasteSpecial xlPasteValues .Cells(1).Activate End With Else 'Format the summary sheet if the user has created separate target sheets ws1.Activate ws1.Range("A1:B1").Font.Bold = True ws1.Columns.AutoFit End If With Application .CutCopyMode = False .DisplayAlerts = True .EnableEvents = True .ScreenUpdating = True .Calculation = lngCalc .StatusBar = vbNullString End With End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant 'From Ken Puls as used in his vbaexpress.com article 'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284 Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function </code><code></code></pre>
consolidating data of one shared workbook then transfer in one specific workbook, without replicating the previos data??
CONSOLIDATE WORKBOOK
Sub CopyAllOpenBooksVer4()
Dim Sh As Worksheet
Dim Wb As Workbook
For Each Wb In Workbooks
If Not Wb.Name = ThisWorkbook.Name Then
For Each Sh In Wb.Worksheets
On Error Resume Next
ConstRng = Sh.Cells.SpecialCells(xlCellTypeConstants, 3).Address
On Error Resume Next
FormRng = Sh.Cells.SpecialCells(xlCellTypeFormulas, 3).Address
If FormRng = "" Then FormRng = ConstRng
If ConstRng = "" Then ConstRng = FormRng
If Not FormRng = "" And Not ConstRng = "" Then
Start = Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Union(Sh.Range(FormRng), Sh.Range(ConstRng)).EntireRow.Copy
Range("A" & Start).PasteSpecial Paste:=xlPasteValues
Range("A" & Start).PasteSpecial Paste:=xlPasteFormats
' PLACE BOOK NAME IN COLUMN X AND SHEET NAME IN COLUMN Y
Range("Z" & Start & ":Z" & Cells.SpecialCells(xlCellTypeLastCell).Row) = Wb.Name
Range("Y" & Start & ":Y" & Cells.SpecialCells(xlCellTypeLastCell).Row) = Sh.Name
FormRng = ""
ConstRng = ""
End If
Next Sh
End If ' WB name not this one
Next Wb
End Sub
<code>
COMBINED INTO ONE WORKBOOK
Option Explicit Public u_sheets As String Sub Consolidate() Dim ws As Worksheet Dim wb As Workbook, NewBook As Workbook Dim scount As Integer Dim NewWS As Worksheet Dim wsSheet As Worksheet Dim i As Integer Dim NextName As String Dim sl As Integer Dim newfilepath As String newfilepath = "" Dim first_only As Boolean first_only = False Call init 'are we doing the first sheet only? If u_sheets = "First Sheet Only" Then first_only = True 'Setup Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False 'Create new workbook for merged sheets newfilepath = ThisWorkbook.Path & "\Merged" 'excel will auto append the appropriate extension (xlsx) Set NewBook = Workbooks.Add NewBook.SaveAs Filename:=newfilepath i = 1 'Loop through each open workbook For Each wb In Workbooks If wb.Name <> ThisWorkbook.Name And wb.Name <> NewBook.Name And Left(wb.Name, 8) <> "PERSONAL" Then Dim x As String 'Get name of this workbook x = JustText(Left(wb.Name, Len(wb.Name) - 4)) 'count sheets in this workbook If first_only Then scount = 1 Else scount = wb.Sheets.Count End If 'Loop through each sheet in Workbook For Each ws In wb.Worksheets 'do some naming conventions Dim xy As String Dim y As String y = JustText(ws.Name) 'strip out all characters from name If scount > 1 Then xy = x + y Else xy = x End If 'check the length of the new name and shorten if needed sl = Len(xy) If sl > 30 Then xy = Right(x, sl - (sl - 30)) End If 'copy worksheet to new workbook ws.Copy After:=NewBook.Worksheets(NewBook.Worksheets.Count) 'rename worksheet NewBook.Worksheets(NewBook.Worksheets.Count).Name = xy If scount = 1 Then Exit For 'break out of loop if we are only doing one sheet Next End If Next 'remove all original worksheets 'NewBook.Worksheets("Sheet1").Delete 'NewBook.Worksheets("Sheet2").Delete 'NewBook.Worksheets("Sheet3").Delete ErrorExit: 'Cleanup Application.DisplayAlerts = True 'turn system alerts back on Application.EnableEvents = True 'turn other macros back on Application.ScreenUpdating = True 'refreshes the screen End Sub Private Function JustText(text_to_clean As String, Optional upper As Boolean = False) 'removes all characters except for letters and numbers 'where 'text_to_clean is the text to clean 'upper boolean will return UPPER case if true; false if omitted 'declare and initialize user variables Dim method As Integer 'choices: '1=remove everything except what is in the leave_these variable '2=leave everything except what is specifically removed from the "leave" section method = 1 Dim leave_these As String 'only used if method=1 leave_these = "A-Za-z0-9" 'if you want to allow a space "A-Za-z0-9 " 'declare and initialize system variables Dim temp As String temp = text_to_clean 'method Select Case method Case 1 'remove everything except what is in the leave_these variable Dim x As String, y As String, z As String, i As Long x = temp For i = 1 To Len(x) y = Mid(x, i, 1) If y Like "[" & leave_these & "]" Then z = z & y Next i temp = z Case 2 'leave everything except characters below 'feel free to comment out the lines for items you do not wish to remove, or add new lines as desired temp = Replace(temp, ",", "") 'remove commas temp = Replace(temp, " ", "") 'remove spaces temp = Replace(temp, "-", "") 'remove dashes temp = Replace(temp, ":", "") 'remove colon temp = Replace(temp, ";", "") 'remove semi-colon End Select If upper Then JustText = UCase(temp) Else JustText = temp End Function Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean On Error Resume Next WorksheetExists = (Sheets(WorksheetName).Name <> "") On Error GoTo 0 End Function Private Sub init() 'initialize all public variables u_sheets = Range("u_sheets") End Sub
</code></pre>
- Collate all sheets from all Excel workbooks in a single folder into a single summary worksheet
- Collate all sheets from all Excel workbooks in a single folder into a single summary workbook
- Collate all sheets from a single Excel workbook into a single summary worksheet
<code>
</code><code>Public Sub ConsolidateSheets() Dim Wb1 As Workbook Dim Wb2 As Workbook Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Dim rng1 As Range Dim rng2 As Range Dim rng3 As Range Dim rngArea As Range Dim lrowSpace As Long Dim lSht As Long Dim lngCalc As Long Dim lngRow As Long Dim lngCol As Long Dim X() Dim bProcessFolder As Boolean Dim bNewSheet As Boolean Dim StrPrefix Dim strFileName As String Dim strFolderName As String 'variant declaration needed for the Shell object to use a default directory Dim strDefaultFolder As Variant bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes) bNewSheet = (MsgBox("Extract all data to a single sheet (Yes)," & vbNewLine & "or a target file sheet for each source sheet (No)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes) If Not bProcessFolder Then If Not bNewSheet Then MsgBox "There isn't much point creating a exact replica of your source file
" Exit Sub End If End If 'set default directory here if needed strDefaultFolder = "C:\temp" 'If the user is collating all the sheets to a single target sheet then the row spacing 'to distinguish between different sheets can be set here lrowSpace = 1 If bProcessFolder Then strFolderName = BrowseForFolder(strDefaultFolder) 'Look for xls, xlsx, xlsm files strFileName = Dir(strFolderName & "\*.xls*") Else strFileName = Application _ .GetOpenFilename("Select file to process (*.xls*), *.xls*") End If Set Wb1 = Workbooks.Add(1) Set ws1 = Wb1.Sheets(1) If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count") 'Turn off screenupdating, events, alerts and set calculation to manual With Application .DisplayAlerts = False .EnableEvents = False .ScreenUpdating = False lngCalc = .Calculation .Calculation = xlCalculationManual End With 'set path outside the loop StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString) Do While Len(strFileName) > 0 'Provide progress status to user Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255) 'Open each workbook in the folder of interest Set Wb2 = Workbooks.Open(StrPrefix & strFileName) If Not bNewSheet Then 'add summary details to first sheet ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count End If For Each ws2 In Wb2.Sheets If bNewSheet Then 'All data to a single sheet 'Skip importing target sheet data if the source sheet is blank Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious) If Not rng2 Is Nothing Then Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious) 'Find the first blank row on the target sheet If Not rng1 Is Nothing Then Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A")) 'Ensure that the row area in the target sheet won't be exceeded If rng3.Rows.Count + rng1.Row < Rows.Count Then 'Copy the data from the used range of each source sheet to the first blank row 'of the target sheet, using the starting column address from the source sheet being copied ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column) Else MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _ "sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name Wb2.Close False Exit Do End If 'colour the first of any spacer rows If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen Else 'target sheet is empty so copy to first row ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column) End If End If Else 'new target sheet for each source sheet ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count) 'Remove any links in our target sheet With Wb1.Sheets(Wb1.Sheets.Count).Cells .Copy .PasteSpecial xlPasteValues End With On Error Resume Next Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name 'sheet name already exists in target workbook If Err.Number <> 0 Then 'Add a number to the sheet name till a unique name is derived Do lSht = lSht + 1 Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht) Loop While Not ws3 Is Nothing lSht = 0 End If On Error GoTo 0 End If Next ws2 'Close the opened workbook Wb2.Close False 'Check whether to force a DO loop exit if processing a single file If bProcessFolder = False Then Exit Do strFileName = Dir Loop 'Remove any links if the user has used a target sheet If bNewSheet Then With ws1.UsedRange .Copy .Cells(1).PasteSpecial xlPasteValues .Cells(1).Activate End With Else 'Format the summary sheet if the user has created separate target sheets ws1.Activate ws1.Range("A1:B1").Font.Bold = True ws1.Columns.AutoFit End If With Application .CutCopyMode = False .DisplayAlerts = True .EnableEvents = True .ScreenUpdating = True .Calculation = lngCalc .StatusBar = vbNullString End With End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant 'From Ken Puls as used in his vbaexpress.com article 'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284 Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function </code><code></code></pre>
