Hi I have main excel file with 10 sheets (sheet1...sheet10), and i need help with extracting (create new folder with sheet name) sheet5 and sheet6 in folder which link is in sheet1 n6 cell, and sheet7 and sheet8 in folder which link is in sheet1 n7 cell.sheets must be extracted without macros and formulas, only paste as values. For now i only have this which is creating workbooks in main file folder, i dont know how to setup extracting in diferent folders.
Private Sub CommandButton2_Click()
Dim xWs As Worksheet
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("Done.")
End Sub
Export Single Worksheets to Workbooks
Option Explicit
Private Sub CommandButton2_Click()
Const lName As String = "Sheet1"
' The following two lines are dependent on each other.
Dim dExtension As String: dExtension = ".xlsx"
Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
Dim lCellAddresses As Variant: lCellAddresses = Array("N6", "N7")
Dim dNames As Variant: dNames = Array( _
Array("Sheet5", "Sheet6"), _
Array("Sheet7", "Sheet8"))
Dim swb As Workbook: Set swb = ThisWorkbook
Dim lws As Worksheet: Set lws = swb.Worksheets(lName)
Application.ScreenUpdating = False
Dim dwb As Workbook
Dim sws As Worksheet
Dim dFilePath As String
Dim n As Long
For Each sws In swb.Worksheets
For n = LBound(dNames) To UBound(dNames)
If IsNumeric(Application.Match(sws.Name, dNames(n), 0)) Then
sws.Copy
Set dwb = ActiveWorkbook
With dwb.Worksheets(1).UsedRange
.Value = .Value
End With
dFilePath = CStr(lws.Range(lCellAddresses(n)).Value)
If Right(dFilePath, 1) <> "\" Then dFilePath = dFilePath & "\"
If Left(dExtension, 1) <> "." Then dExtension = "." & dExtension
dFilePath = dFilePath & sws.Name & dExtension
Application.DisplayAlerts = False ' overwrite: no confirmation
dwb.SaveAs Filename:=dFilePath, FileFormat:=dFileFormat
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Exit For
End If
Next n
Next sws
Application.ScreenUpdating = True
MsgBox "Worksheets exported.", vbInformation
End Sub
Related
I have a workbook with filtered ranges on each sheet. I have tried a couple different methods but when stepping through it only does the first sheet or none at all. This is what I have tried.
dim ws as worksheet
For Each Ws In ThisWorkbook.Worksheets
If Ws.AutoFilterMode Then
Ws.AutoFilter.ShowAllData
End If
Next Ws
this one isn't doing anything at all
this one is less sophisticated and not what I want.
For Each ws In ThisWorkbook.Worksheets
Rows("1:1").Select
Selection.AutoFilter
Next ws
this is only doing the first worksheet and not moving to the next.
this is the full code and it is not returning any errors
Sub Cleanup()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim mergedWb As Workbook
Set mergedWb = Workbooks.Add()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Dim ws As Worksheet
Application.ScreenUpdating = False
FolderPath = "<folder path>"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
For Each Sheet In wb.Sheets
Sheet.Copy After:=mergedWb.Sheets(1)
Next Sheet
wb.Close
Filename = Dir()
Loop
Sheets(1).Delete
For Each ws In ThisWorkbook.Worksheets
If ws.AutoFilterMode Then
ws.AutoFilter.ShowAllData
End If
Next ws
End Sub
Copy Sheets to New Workbook
Issues
ThisWorkbook is the workbook containing this code. It has nothing to do with the code so far: you're adding a new (destination) workbook (mergedWb) and you're opening (source) files ('wb') whose sheets (Sheet) will be copied. Instead, you should use:
For Each ws In mergedWb.Worksheets
When you use the Sheets collection, you need to keep in mind that it also includes charts. Therefore, you should declare:
Dim Sheet As Object
You need to qualify the first destination (work)sheet to ensure the correct worksheet is deleted:
Application.DisplayAlerts = False ' delete without confirmation
mergedWb.Sheets(1).Delete
Application.DisplayAlerts = True
To turn off the auto filter, you need to use:
dws.AutoFilterMode = False
You can avoid the loop by copying all sheets (that are not very hidden) at once (per workbook):
swb.Sheets.Copy After...
The line swb.Sheets.Copy (no arguments) copies all sheets (that are not very hidden) to a new workbook.
The Code
Option Explicit
Sub Cleanup()
Const SOURCE_FOLDER_PATH As String = "C:\Test"
Const SOURCE_FILE_PATTERN As String = "*.xls*"
If Not CreateObject("Scripting.FileSystemObject") _
.FolderExists(SOURCE_FOLDER_PATH) Then
MsgBox "The folder '" & SOURCE_FOLDER_PATH & "' doesn't exist.", _
vbCritical
Exit Sub
End If
Dim sFolderPath As String: sFolderPath = SOURCE_FOLDER_PATH
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
Dim sFileName As String: sFileName = Dir(sFolderPath & SOURCE_FILE_PATTERN)
If Len(sFileName) = 0 Then
MsgBox "No files found."
Exit Sub
End If
Dim swb As Workbook
Dim dwb As Workbook
Dim sFilePath As String
Dim IsNotFirstSourceWorkbook As Boolean
Application.ScreenUpdating = False
Do While Len(sFileName) > 0
sFilePath = sFolderPath & sFileName
Set swb = Workbooks.Open(Filename:=sFilePath, ReadOnly:=True)
If IsNotFirstSourceWorkbook Then
swb.Sheets.Copy After:=dwb.Sheets(dwb.Sheets.Count)
Else
swb.Sheets.Copy ' creates a new workbook containing the sheets
Set dwb = Workbooks(Workbooks.Count)
IsNotFirstSourceWorkbook = True
End If
swb.Close SaveChanges:=False
sFileName = Dir()
Loop
Dim dws As Worksheet
For Each dws In dwb.Worksheets
If dws.AutoFilterMode Then dws.AutoFilterMode = False
Next dws
' Decide what to do with the new workbook e.g.:
' Application.DisplayAlerts = False ' overwrite without confirmation
' dwb.SaveAs sFolderPath & "CleanUp " & Format(Date, "yyyymmdd")
' Application.DisplayAlerts = True
' dwb.Close SaveChanges:=False ' it has just been saved
Application.ScreenUpdating = True
MsgBox "Cleaned up.", vbInformation
End Sub
I am using this code which exports activesheet to CSV. However, I am looking to modify this so I can pass as arguments the names of multiple sheets to export.
Sometimes it could be 2 sheets, sometimes it could be 10 sheets and I want to somehow define the names of the sheets as parameters for the export.
Sub saveSheetToCSV()
Dim myCSVFileName As String
Dim tempWB As Workbook
Application.DisplayAlerts = False
On Error GoTo err
myCSVFileName = ThisWorkbook.Path & "\" & "CSV-Exported-File-" & VBA.Format(VBA.Now, "dd-MMM-yyyy hh-mm") & ".csv"
ThisWorkbook.Sheets("YourSheetToCopy").Activate
ActiveSheet.Copy
Set tempWB = ActiveWorkbook
With tempWB
.SaveAs Filename:=myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
err:
Application.DisplayAlerts = True
End Sub
Export Worksheet to New Workbook
!!! denotes places to be checked carefully and possibly modified.
Option Explicit
Sub ExportWorksheetsTEST()
Dim wb As Workbook: Set wb = Workbooks.Open("C:\Test\Test.xlsx")
ExportWorksheets "Sheet1", "Sheet5", "Sheet8"
End Sub
Sub ExportWorksheets(ParamArray WorkSheetNames() As Variant)
Dim dFolderPath As String: dFolderPath = ThisWorkbook.Path & "\"
Const dFileExtension As String = ".csv"
Const dDateFormat As String = "dd-MMM-yyyy hh-mm"
Const dFileNameDelimiter As String = "-"
' This is the requirement.
' The recommendation is to put it as the first parameter of the procedure:
' Sub ExportWorksheets(ByVal wb As Workbook, ParamArray...)!!!
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim dDateString As String: dDateString = VBA.Format(VBA.Now, dDateFormat)
Dim ws As Worksheet
Dim n As Long
Dim dFilePath As String
For n = LBound(WorkSheetNames) To UBound(WorkSheetNames)
On Error Resume Next ' prevent error if worksheet doesn't exist
Set ws = wb.Worksheets(WorkSheetNames(n))
On Error GoTo 0
If Not ws Is Nothing Then
' Build the file path!!!
dFilePath = dFolderPath & ws.Name & dFileNameDelimiter _
& dDateString & dFileExtension
ws.Copy ' copy to a new workbook
With Workbooks(Workbooks.Count)
Application.DisplayAlerts = False ' overwrite w/o confirmation
.SaveAs Filename:=dFilePath, FileFormat:=xlCSV
Application.DisplayAlerts = True
.Close SaveChanges:=False
End With
Set ws = Nothing
End If
Next n
MsgBox "Worksheets exported.", vbInformation
End Sub
Hi I have the following code which loops through dropdown selections and saves each result as a new workbook based on the named range in cell G3. I am trying to edit the code so that it saves all the worksheets to the new file instead of just the active one, if anyone could help? thank you
Sub myFiles()
Dim wb As Workbook
Dim ws As Worksheet
Dim nwb As Workbook
Dim nws As Worksheet
Dim rng As Range
Dim Path As String
Dim myDate As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Summary")
Set rng = ws.Range("G3")
Path = "C:\Users\bradley\Desktop\Sales by Month\"
myDate = Format(Now(), "MM-DD-YYYY")
For i = 1 To 4
rng = ws.Range("J" & i)
ws.Copy
Set nwb = ActiveWorkbook
Set nws = nwb.Worksheets("Summary")
With nws
Cells.Copy
Cells.PasteSpecial (xlPasteValues)
End With
Application.DisplayAlerts = False
nwb.SaveAs FileName:=Path & rng & " " & myDate & ".xlsx",
FileFormat:=xlWorkbookDefault
nwb.Close
Application.DisplayAlerts = True
Next i
End Sub
Loop through the sheets but only create a workbook on the first one.
Option Explicit
Sub myFiles()
Const FOLDER = "C:\Users\bradley\Desktop\Sales by Month\"
Dim wb As Workbook, nwb As Workbook
Dim ws As Worksheet, rng As Range
Dim myDate As String, i As Long, j As Long
Dim filename As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Summary")
Set rng = ws.Range("G3")
myDate = Format(Now(), "MM-DD-YYYY")
Application.ScreenUpdating = False
For i = 1 To 4
rng.Value2 = ws.Range("J" & i).Value2
' copy all sheets
For j = 1 To wb.Sheets.Count
If j = 1 Then
wb.Sheets(j).Copy
Set nwb = ActiveWorkbook
Else
wb.Sheets(j).Copy after:=nwb.Sheets(j - 1)
End If
With nwb.Sheets(j)
.UsedRange.Value2 = .UsedRange.Value2
End With
Next
' save workbook
filename = FOLDER & rng.Value2 & " " & myDate & ".xlsx"
Application.DisplayAlerts = False
nwb.SaveAs filename:=filename, FileFormat:=xlWorkbookDefault
nwb.Close
Application.DisplayAlerts = True
Next i
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
I'm trying to loop through files in a folder with following path "C:\Users\Ouen\Downloads\Test" and paste each output into a new specific sheet in a MASTER workbook.
For example, the below are all the same worksbooks that each have a specific worksheet called "Annual" with different outputs:
Asset1
Asset2
Asset3
Etc
I would like to copy the whole Annual worksheet from each of the workbooks above and paste into a MASTER workbook, while being able to rename them to the following:
Asset1 - Annual
Asset2 - Annual
Asset3 - Annual
Etc
I have had some luck in copying and pasting from each workbook into the master but I'm unable to to paste each output into a new worksheet within the master and rename. Any ideas?
Sub Assets2Master()
Dim xRg As Range
Dim xSelItem As Variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Annual"
xRgStr = "B1:GI100"
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDlg
If .Show = -1 Then
xSelItem = .SelectedItems.Item(1)
Set xWorkBook = ThisWorkbook
Set xSheet = xWorkBook.Sheets("MASTER")
If xSheet Is Nothing Then
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "MASTER"
Set xSheet = xWorkBook.Sheets("MASTER")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
If xFileName = "" Then Exit Sub
Do Until xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir()
xBook.Close
Loop
End If
End With
et xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Copy to the end
This code will copy, if it exists, the Annual worksheet from each workbook in the folder you select via the dialog.
They will be copied to the workbook the code is in and the copied sheets will be renamed with the name of the workbook they came from appended with - Annual.
The copied sheets will be copied after the last sheet in the MASTER workbook.
Sub Assets2Master()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim dlg As Object
Dim strFileName As String
Dim strFolder As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
With dlg
If .Show = -1 Then
strFolder = .SelectedItems.Item(1)
End If
End With
Set wbDst = ThisWorkbook
strFileName = Dir(strFolder & "\*.xlsx", vbNormal)
If strFileName = "" Then Exit Sub
Do Until strFileName = ""
If strFileName <> wbDst.Name Then
Set wbSrc = Workbooks.Open(strFolder & "\" & strFileName)
' check if 'Annual' sheet exists, and if it does copy it to master workbook
If IfSheetExists("Annual", wbSrc) Then
Set wsSrc = wbSrc.Sheets("Annual")
With wbDst
wsSrc.Copy After:=.Sheets(.Sheets.Count)
.Sheets(.Sheets.Count).Name = Left(strFileName, Len(strFileName) - 5) & " - Annual"
End With
End If
wbSrc.Close SaveChanges:=False
End If
strFileName = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function IfSheetExists(strName As String, Optional wb As Workbook) As Boolean
' checks for the existence of a worksheet named strName in the, optional, workbook wb
' if wb not stated checks in the active workbook
Dim ws As Worksheet
If wb Is Nothing Then
Set wb = ActiveWorkbook
End If
For Each ws In wb.Sheets
If ws.Name = strName Then
IfSheetExists = True
Exit For
End If
Next ws
End Function
Copy after specific sheet
This code is basically identical to the previous code but the workheets will be copied after a specific worksheet in the MASTER workbook.
Option Explicit
Sub Assets2Master()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim dlg As Object
Dim strFileName As String
Dim strFolder As String
Dim lngDstIndex As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
With dlg
If .Show = -1 Then
strFolder = .SelectedItems.Item(1)
End If
End With
Set wbDst = ThisWorkbook
' change Specific Tab to the name ypu want the sheets to be copied after
lngDstIndex = wbDst.Sheets("Specific Tab").Index
strFileName = Dir(strFolder & "\*.xlsx", vbNormal)
If strFileName = "" Then Exit Sub
Do Until strFileName = ""
If strFileName <> wbDst.Name Then
Set wbSrc = Workbooks.Open(strFolder & "\" & strFileName)
' check if 'Annual' sheet exists, and if it does copy it to master workbook
If IfSheetExists("Annual", wbSrc) Then
Set wsSrc = wbSrc.Sheets("Annual")
With wbDst
' copy sheet to MASTER workbook
wsSrc.Copy After:=.Sheets(.Sheets.Count)
' rename sheet and move it after specified sheet
With .Sheets(.Sheets.Count)
.Name = Left(strFileName, Len(strFileName) - 5) & " - Annual"
.Move After:=wbDst.Sheets(lngDstIndex)
lngDstIndex = lngDstIndex + 1
End With
End With
End If
wbSrc.Close SaveChanges:=False
End If
strFileName = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function IfSheetExists(strName As String, Optional wb As Workbook) As Boolean
' checks for the existence of a worksheet named strName in the, optional, workbook wb
' if wb not stated checks in the active workbook
Dim ws As Worksheet
If wb Is Nothing Then
Set wb = ActiveWorkbook
End If
For Each ws In wb.Sheets
If ws.Name = strName Then
IfSheetExists = True
Exit For
End If
Next ws
End Function
Try this. The Master wb should be placed in a different folder than the one you store the Asset Files:
Sub Assets2Master()
Dim xRg As Range
Dim xSelItem As Variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Annual"
xRgStr = "B1:GI100"
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDlg
If .Show = -1 Then
xSelItem = .SelectedItems.item(1)
Set xWorkBook = ActiveWorkbook
Set xSheet = xWorkBook.Sheets("MASTER")
If xSheet Is Nothing Then
xWorkBook.Sheets.Add(After:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "MASTER"
Set xSheet = xWorkBook.Sheets("MASTER")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
If xFileName = "" Then Exit Sub
Do Until xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir()
xBook.Close
xBook.Name = xBook.Name & " - Annual"
Loop
End If
End With
Set xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Stack Ranges
This is about what I thought your code was supposed to do. What you asked for is kind of illustrated with the commented block of code in the Do...Loop. By modifying the code in the Do...Loop, there are many possibilities of what you could achieve.
Option Explicit
Sub StackRanges()
' Source
Const sName As String = "Sheet1" ' "Annual"
Const sAddress As String = "B1:GI100"
' Destination
Const dName As String = "MASTER"
Const dCol As String = "A"
Application.ScreenUpdating = False
' Open the dialog to pick a folder.
Dim xFileDlg As FileDialog
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Dim sFolderPath As Variant
With xFileDlg
.InitialFileName = ThisWorkbook.Path
If .Show = True Then
sFolderPath = .SelectedItems.Item(1)
Else
MsgBox "Canceled.", vbExclamation, "Assets2Master"
Exit Sub
End If
End With
' Write the name of the first file to the Source File Name variable.
Dim sfName As String: sfName = Dir(sFolderPath & "\*.xlsx")
' Validate first Source File Name.
If Len(sfName) = 0 Then Exit Sub ' no files found
' Create a reference to the Destination Workbook.
Dim dwb As Workbook: Set dwb = ThisWorkbook
' Write the name of the Destination Workbook
' to the Destination File Name variable.
Dim dfName As String: dfName = dwb.Name
' Attempt to create a reference to the Destination Worksheet.
Dim dws As Worksheet
On Error Resume Next
Set dws = dwb.Worksheets(dName)
On Error GoTo 0
' If the attempt was unsuccessful, add a new worksheet and do it now.
If dws Is Nothing Then
dwb.Worksheets.Add(After:=dwb.Sheets(dwb.Sheets.Count)).Name = dName
Set dws = dwb.Worksheets(dName)
' Maybe add some headers... to the Destination Worksheet.
End If
' Create a reference to the (first) Destination Range.
Dim drg As Range: Set drg = dws.Range(sAddress)
Dim rCount As Long: rCount = drg.Rows.Count
Dim cCount As Long: cCount = drg.Columns.Count
Set drg = dws.Cells(dws.Rows.Count, dCol).End(xlUp) _
.Offset(1, 0).Resize(rCount, cCount)
' Declare additional variables for the following 'Do Loop'.
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
' Loop through the files in the folder...
Do Until Len(sfName) = 0
' Check if the Source File Name is different
' than the Destination File Name.
If StrComp(sfName, dfName, vbTextCompare) <> 0 Then
' Open and create a reference to the Source Workbook.
Set swb = Workbooks.Open(sFolderPath & "\" & sfName)
' Attempt to create a reference to the Source Worksheet.
Set sws = Nothing
On Error Resume Next
Set sws = swb.Worksheets(sName)
On Error GoTo 0
' Stack Ranges
' If the attempt was successful...
If Not sws Is Nothing Then
' Create a reference to the Source Range.
Set srg = sws.Range(sAddress)
' Copy the values from the Source to the Destination Range
' by assignment.
drg.Value = srg.Value
' Create a reference to the (next) Destination Range.
Set drg = drg.Offset(rCount)
End If
' ' Copy Worksheets (instead)
'
' ' If the attempt was successful...
' If Not sws Is Nothing Then
' sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
' ' Caution: Has to be less than 32 characters!
' ActiveSheet.Name = Left(sfName, Len(sfName) - 5) & " - " & sName
' End If
' Close the Source Workbook.
swb.Close SaveChanges:=False
End If
' Write the name of the next file to the Source File Name variable.
sfName = Dir
Loop
Application.ScreenUpdating = True
' Inform the user.
MsgBox "Data copied.", vbInformation, "Assets2Master"
End Sub
so I have about 21 sheets that are all named the exact same across about 16 files. All the formats and such are the exact same, so for example I need to combine all the sheets with "Age" in all 16 files into a master file that will have the "Age" sheet with the aggregated data of all 16 "Age" sheets. Similarly for the other 20 sheet types.
I'm not sure how exactly to do this. I have a macro that currently adds all sheets in a file together into one master workbook, and I'm looking to modify this so it combines similar sheets instead of just adding them all into one workbook.
Any ideas would be appreciated!
Sub AddAllWS()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "C:\Documents and Settings\path\to"
Set wbDst = ThisWorkbook
strFilename = Dir(MyPath & "\*.xls", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.UsedRange.Copy
wsSrc.Paste (wbSrc.Range("A" & Rows.Count).End(xlUp).Offset(1))
wbSrc.Close False
strFilename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
You seem to be copying and pasting into the same source worksheet. Check the code below. That might work. I put in comments in the code.
Sub AddAllWS()
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Dim lLastRow As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wbDst = ThisWorkbook
MyPath = "C:\Documents and Settings\path\to\"
strFilename = Dir(MyPath & "*.xls*", vbNormal)
Do While strFilename <> ""
Set wbSrc = Workbooks.Open(MyPath & strFilename)
'loop through each worksheet in the source file
For Each wsSrc In wbSrc.Worksheets
'Find the corresponding worksheet in the destination with the same name as the source
On Error Resume Next
Set wsDst = wbDst.Worksheets(wsSrc.Name)
On Error GoTo 0
If wsDst.Name = wsSrc.Name Then
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
wsSrc.UsedRange.Copy
wsDst.Range("A" & lLastRow).PasteSpecial xlPasteValues
End If
Next wsSrc
wbSrc.Close False
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub