I am trying to copy Range(A14:N26) from every closed workbook in a folder on my desktop and paste them into the current worksheet (which is my master worksheet). The code does grab the right range of data but struggles with the pasting part.
It is supposed to SpecialPaste the code as there are formulas in the cells and I want to only copy what is visible in the cells. (Note: The outcome of some of of the formulas are words, the outcome of others are numbers)
Option Explicit
Sub CopySheetFromFileOnDesktop()
Dim wkbDest As Workbook
Dim wksDest As Worksheet
Dim wkbSource As Workbook
Dim wksSource As Worksheet
Dim MyPath As String
Dim MyFile As String
Dim SheetIndex As Integer
Application.ScreenUpdating = False
Set wkbDest = ThisWorkbook
Set wksDest = wkbDest.Worksheets("Master Sheet")
SheetIndex = 1
MyPath = "C:\Users\.."
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
MyFile = Dir(MyPath & "*.xlsm")
Do While Len(MyFile) > 0
Set wkbSource = Workbooks.Open(MyPath & MyFile)
Set wksSource = wkbSource.Worksheets("Sheet containing the info")
If WorksheetFunction.CountA(wkbSource.Sheets("Sheet containing the
info").Range("A14:L26")) <> 0 Then
'lRow = .Range("L" & Rows.Count).End(xlUp).Row 'UNSURE HOW TO LAST ROW
wkbSource.Sheets("Sheet containing the info").Range("A14:L26").Copy
wkbDest.Range("A:L" & Rows.Count).End(xlUp)(2).PasteSpecial _
Paste:=xlPasteValues 'PASTESPECIAL SEEMS TO BE THE PROBLEM
wkbSource.Close savechanges:=False
Application.CutCopyMode = False
Else
End If
Loop
Application.ScreenUpdating = True
MsgBox "Completed...", vbInformation
End Sub
when running the macro it shows this bug: Runtime Error 438: Object does not support Properties or Method. And the debugger highlights the line where I define where to paste the copied range
The code row with your destination range needs an optimization:
You erroneously used wkbDest instead of wksDest
A partly row can not be addressed by Range("A:L" & 1000)
If you use Rows.Count without a leading dot, then the ActiveSheet is assumed
First attempt
wksDest.Cells(wksDest.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 12).PasteSpecial _
Paste:=xlPasteValues
The destination is built as follows:
Find the last used cell in column 1 (e. g. A100)
Offset it to the next row (e. g. A101)
Resize it to a new dimension of 1 row and 12 columns (e. g. A101:L101)
Second attempt:
If you paste, it is only necessary to address the first cell of the destination. So following should also work:
wksDest.Cells(wksDest.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues
Recommendation:
If you define source and destination range of the same size, you can just assign their values (simular to PastSpecial of values, but faster):
wksDest.Cells(wksDest.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 12).Value = _
wksSource.Range("A14:L26").Value
Related
I have a challenge on achieving the below project, kindly please assist:
I have four source workbooks with names(GK,SK,RJ and TB).
Each workbook(GK,SK,RJ and TB) have three worksheets with the same names(products, channels, and sales).
I have destination workbook called consolidated workbook with the same worksheets names(products, channels, and sales) like those of the four source workbooks.
All workbooks(source + destinations) are in the same folder.
Iam requesting VBA code that will copy data from each worksheet of all the four source workbooks and transfer/paste the data to worksheets in consolidated workbook based on the rows that were not previously copied from the last copy event.
Currently I have the below code but whenever I ran it copies everything from worksheets on the source workbooks and paste to worksheets in consolidated workbook which result to duplicated data.
All the source workbook have worksheets with the "DATE" as a first column in each worksheet table column.
Destination workbook also have the same worksheet names and the same columns structure on each worksheet are the same as of those source worksheet.
Kindly advise what should I amend so that the code will that will copy data from each worksheet of all the four source workbooks and transfer/paste the data to worksheets in consolidated workbook based on the rows that were not previously copied from the last copy event.
Sub Copy_From_All_Workbooks()
Dim wb As String, i As Long, sh As Worksheet
Application.ScreenUpdating = False
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
For Each sh In Workbooks(wb).Worksheets
sh.UsedRange.Offset(1).Copy '<---- Assumes 1 header row
ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next sh
Workbooks(wb).Close False
End If
wb = Dir
Loop
Application.ScreenUpdating = True
End Sub
Kindly please see the amended code:
Sub Copy_From_All_Workbooks()
Dim wb As String, i As Long, sh As Worksheet, fndRng As Range,
start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As
Range
Application.ScreenUpdating = False
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
For Each sh In Workbooks(wb).Worksheets
On Error Resume Next
sh.UsedRange.Offset(1).Copy '<---- Assumes 1 header row
Set fndRng = sh.Range("A:A").Find(date_to_find,LookIn:=xlValues,
searchdirection:=xlPrevious)
If Not fndRng Is Nothing Then
start_of_copy_row = fndRng.Row + 1
Else
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
Set range_to_copy = Range(start_of_copy_row & ":" & end_of_copy_row)
latest_date_loaded = Application.WorksheetFunction.Max(ThisWorkbook.Sheets(sh.Name).Range("A:A"))
ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
On Error GoTo 0
Application.CutCopyMode = False
Next sh
Workbooks(wb).Close False
End If
wb = Dir
Loop
Application.ScreenUpdating = True
End Sub
Kindly please see how consolidated workbook appear(the sheet names and column format are exactly the same as of the source workbooks.)
CONSOLIDATED WORKBOOK
The following line can be used to find the latest date loaded on your consolidated sheet:
latest_date_loaded = Application.WorksheetFunction.Max(ThisWorkbook.Sheets(sh.Name).Range("A:A"))
The following lines can be used on a worksheet (sh) to create a range (for copying) that starts after the latest_date_loaded down to the bottom of the table. You'll therefore need to ensure this is in date order.
Dim fndRng As Range, start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As Range
date_to_find = latest_date_loaded
Set fndRng = sh.Range("A:A").Find(date_to_find, LookIn:=xlValues, searchdirection:=xlPrevious)
If Not fndRng Is Nothing Then
start_of_copy_row = fndRng.Row + 1
Else
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
Set range_to_copy = Range(start_of_copy_row & ":" & end_of_copy_row)
EDIT
Here is a rework of your code, using some of the lines/ideas I've mentioned above.
Sub Copy_From_All_Workbooks()
'declarations
Dim wb As String, i As Long, sh As Worksheet, fndRng As Range, _
start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As _
Range, latest_date_loaded As Date, consolidated_wb As Workbook
'turn off screen updating for user experience
'Application.ScreenUpdating = False
'set a reference to the consolidated workbook
Set consolidated_wb = ThisWorkbook
'read parent folder of consolidated workbook
wb = Dir(consolidated_wb.Path & "\*")
'perform this loop until no more files
Do Until wb = ""
'make sure it doesn't try to open consolidated workbook (again)
If wb <> consolidated_wb.Name Then
'open found source workbook
Workbooks.Open consolidated_wb.Path & "\" & wb
'cycle through each sheet (sh)
For Each sh In Workbooks(wb).Worksheets
'on that sheet, find the latest date already existing
latest_date_loaded = Application.WorksheetFunction.Max(consolidated_wb.Sheets(sh.Name).Range("A:A"))
'find the last occurence of that date in column A
Set fndRng = sh.Range("A:A").Find(latest_date_loaded, LookIn:=xlValues, _
searchdirection:=xlPrevious)
'if you find that date already then..
If Not fndRng Is Nothing Then
'set the top row to where you found it, plus one
start_of_copy_row = fndRng.Row + 1
Else
'otherwise, it's a new sheet, start on row two
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
'find the end of the table, using column A's contents
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
'make sure there's something to copy
If end_of_copy_row >= start_of_copy_row Then
'create a reference to the block of cells to copy
Set range_to_copy = sh.Range(start_of_copy_row & ":" & end_of_copy_row)
'copy that range
range_to_copy.Copy
'paste them, values only
consolidated_wb.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
'clear copy markings from screen
Application.CutCopyMode = False
Else
'otherwise, do nothing here
End If
Next sh
'close the source workbook
Workbooks(wb).Close False
End If
'get next potential filename
wb = Dir
Loop
'turn back on screen updating
Application.ScreenUpdating = True
End Sub
I'm fairly new to using VBA, but I currently have a code written that does the following:
Searches within a folder, all excel files which contain a specific worksheet, and outputs in to a master sheet.
I am trying to add a column, either at the beginning or end of the master sheet which indicates the file source name. My code is the following
Sub CombineWorkbooks()
'Declare the variables
Dim arrFiles() As String
Dim strPath As String
Dim strFile As String
Dim wkbDest As Workbook
Dim wksDest As Worksheet
Dim wkbSource As Workbook
Dim wksSource As Worksheet
Dim SourceRange As Range
Dim SourceRowCount As Long
Dim NextRow As Long
Dim LastRow As Long
Dim LastCol As Long
Dim FileCnt As Long
Dim Cnt As Long
Dim i As Long
Dim CalcMode As Long
'Specify the path to the folder containing the files
strPath = "FOLDER PATH\"
'Make sure that the path ends in a backslash
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'Check if the path exists
If Len(Dir(strPath, vbDirectory)) = 0 Then
MsgBox "The path to your folder does not exist. Please check" & vbCrLf & _
"the path, and try again!", vbExclamation
Exit Sub
End If
'Get the first Excel file from the folder
strFile = Dir(strPath & "*.xls", vbNormal)
'Fill the array with a list of Excel files in the folder...
FileCnt = 0
Do While Len(strFile) > 0
'...except this workbook, in case it's in the same folder
If strFile <> ThisWorkbook.Name Then
FileCnt = FileCnt + 1
ReDim Preserve arrFiles(1 To FileCnt)
arrFiles(FileCnt) = strFile
End If
'Get the next Excel file from the folder
strFile = Dir
Loop
'If no Excel files were found, exit the sub
If FileCnt = 0 Then
MsgBox "No Excel files were found...", vbExclamation
Exit Sub
End If
'Change the settings for Calculation, DisplayAlerts, EnableEvents,
'and ScreenUpdating
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
'Create a new workbook with one worksheet
Set wkbDest = Workbooks.Add(xlWBATWorksheet)
'Set the destination worksheet
Set wksDest = wkbDest.Worksheets(1)
'Specify the row in which to start copying the data
NextRow = 1
'Loop through each Excel file in the array...
Cnt = 0
For i = LBound(arrFiles) To UBound(arrFiles)
'Open the current file
Set wkbSource = Workbooks.Open(strPath & arrFiles(i))
'Set the source worksheet
On Error Resume Next
Set wksSource = wkbSource.Worksheets("Worksheet you are looking to import")
On Error GoTo 0
'Check if the worksheet exists
If Not wksSource Is Nothing Then
With wksSource
'Find the last used row in Column A
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Find the last used column in Row 1
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Check if the worksheet contains data beyond column headers
If LastRow > 1 Then
'Increase the count by one
Cnt = Cnt + 1
'Set the source range...
If Cnt = 1 Then
'...including the column headers
Set SourceRange = .Range("A1", .Cells(LastRow, LastCol))
Else
'...excluding the column headers
Set SourceRange = .Range("A2", .Cells(LastRow, LastCol))
End If
'Count the number of rows in the source range
SourceRowCount = SourceRange.Rows.Count
'If there aren't enough rows in the destination sheet,
'exit the sub
If NextRow + SourceRowCount - 1 > wksDest.Rows.Count Then
MsgBox "Sorry, there are not enough rows available " & _
"in the destination worksheet!", vbExclamation
wkbSource.Close savechanges:=False
GoTo ExitSub
End If
'Copy the data from the source range to the destination sheet
SourceRange.Copy
With wksDest.Cells(NextRow, "A")
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
'Determine the next available row
NextRow = NextRow + SourceRowCount
End If
End With
'Set the object variable for the source worksheet to Nothing
Set wksSource = Nothing
End If
'Close the current file, without saving it
wkbSource.Close savechanges:=False
Next i
'Check if any data has been copied to the destination worksheet
If Cnt > 0 Then
'Select the first cell and change the width of the columns to
'achieve the best fit
With wksDest
.Cells(1).Select
.Columns.AutoFit
End With
Else
'Display message box advising user that no data was available to be copied
MsgBox "No data was available to be copied...", vbInformation
'Close the destination workbook, without saving it
wkbDest.Close savechanges:=False
End If
ExitSub:
'Restore the settings for Calculation, DisplayAlerts, EnableEvents,
'and ScreenUpdating
With Application
.Calculation = CalcMode
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Any help would be greatly appreciated!
You might want to look at Power Query's "Import from folder" option. When you import all the files from a folder. Using PQ, you can import all the files from a folder (which appends the file name as a new column in the process) and combine and edit that information. One procedure you can do in Power Query is to navigate to a specific worksheet by its name. If you tried to do this navigation on a workbook that didn't have this name, it would cause an error to be raised. In PQ, you can also tell the query to remove any errors. Combined, you could gather all the files in various folders, using a file that has your specific worksheet, you can create a sample query to drill into that worksheet, and perform your other transformations. If you do this step, then remove all the errors, you should be left only with the files that have the worksheet you are looking for, and have the file name for each of those files alongside your data, and that can be dumped into a master table on your worksheet. Plus, you don't have to deal with any overly complicated VBA code (though, I do so love VBA).
Hope this helps!
I have managed put a code together. It is working, but it's not very sufficient as I would need to create a 20 macros and rename the filtered text for each macro. I have two workbooks Q4 where the code saved (Q4 - cell A1:A20 filter text & B1:B20 file name) and and AA workbook where everything happening. How can I create it loops through the workbook Q4 and also the filter selects the range form workbook Q4?
Sub Delete_Rows()
Dim wb As Workbook
Dim ws As Worksheet
Dim Path As String
Dim Filename As String
Dim rng As Range
Dim lastRow As Long
Path = "C:\Users\jam_jam\Desktop\ABC\ABC1\" 'Saves file
Workbooks.Open ("C:\Users\jam_jam\Desktop\ABC\AA.xlsx") 'Opens work book
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ws.Range("D" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("D1:D" & lastRow)
'''''''' filter and delete all but header row
With rng
.AutoFilter Field:=4, Criteria1:="<>*ABCD*" 'I would like to filter by range from workbook Q4
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ws.Name = ws.Range("D2")
ActiveSheet.Range("$A$1:$N$3000").AutoFilter Field:=4
Range("M2").Select
Filename = Workbooks("Q4.xlsm").Worksheets("333").Range("E13")
ActiveWorkbook.SaveAs Filename:=Path & Filename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
End Sub
Thank you for any help?
''' With rng
.AutoFilter field:=4, Criteria1:="<>" & arr & "" 'Filters by excel value
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
I am new at creating macros. Only created 5 of them for specific problems.
Could someone help me amend the below macro? I found it on the internet, I amended it to my preferences. But still there is room from improvement. Anyways it works perfectly except for the below.
There would be a lot of files in folder. Each file contains a tab named "PIVOT", where the format are the same, but the amount of data are different.
The range is in the PIVOT tab are from A to AM columns. They start at row 15. And I would only need those lines where the "closed" indication is not written (Status column is in AJ column). I want all of these rows to be copied into a master file under each other. The amount of rows varies greatly - like 0 to 200 depending on the open items.
Secondly, can someone tell me a book, that could be purchased so that I could evolve my knowledge?
Thank For your help!
Tibor
Sub Import_to_Master()
Dim sFolder As String
Dim sFile As String
Dim wbD As Workbook, wbS As Workbook
Application.ScreenUpdating = False
Set wbS = ThisWorkbook
sFolder = wbS.Path & "\"
sFile = Dir(sFolder)
Do While sFile <> ""
If sFile <> wbS.Name Then
Set wbD = Workbooks.Open(sFolder & sFile) 'open the file; add condition to
' >>>>>> Adapt this part
wbD.Sheets("PIVOT").Range("A15:AM26").Copy
wbS.Activate
Sheets("Template").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
' >>>>>>
wbD.Close savechanges:=True 'close without saving
End If
sFile = Dir 'next file
Loop
Application.ScreenUpdating = True
End Sub
you may be after this:
' >>>>>> Adapted part
With wbD.Sheets("PIVOT")
With .Range("AM14", .Cells(.Rows.count, 1).End(xlUp)) '<--| reference its column "A:AM" range from row 14 down to column "A" last not empty row
.AutoFilter Field:=36, Criteria1:="<>closed" '<--| filter referenced range on its 36th column (i.e. column "AJ") with values different from "closed"
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then
.Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy
Sheets("Template").Range("A" & Rows.count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
End With
.AutoFilterMode = False
End With
' >>>>>>
If you need to check each row for a certain cell value use something like the following. This will loop through line by line checking for lines that don't say "Closed".
Dim sFolder As String, sFile As String, wbD As Workbook, wbS As Workbook
Dim lastRowS As Integer, lastRowD As Integer
Application.ScreenUpdating = False
Set wbS = ThisWorkbook
sFolder = wbS.Path & "\"
sFile = Dir(sFolder
lastRowS = Sheets("Template").Range("A" & Rows.Count).End(xlUp).Row + 1
Do While sFile <> ""
If sFile <> wbS.Name Then
Set wbD = Workbooks.Open(sFolder & sFile) 'open the file; add condition to
lastRowD = wbD.Sheets("PIVOT").Range("A" & Rows.Count).End(xlUp).Row
For i = 15 To lastRowD
If Cells(i, 3) <> "Closed" Then 'change 3 to whatever column number has Closed in
wbD.Sheets("PIVOT").Rows(i).EntireRow.Copy
wbS.Sheets("Template").Cells(lastRowS, 1).PasteSpecial xlPasteValues
lastRowS = lastRowS + 1
End If
Next i
Application.CutCopyMode = False
' >>>>>>
wbD.Close savechanges:=False 'close without saving
End If
sFile = Dir 'next file
Loop
Application.ScreenUpdating = True
End Sub
I have a template file which will be sent out to all subsidiaries of my company.
The template has a tab named start and one named end.
The subsidiaries will place a variable number of template submission sheets between these two names sheets and send them in to me to consolidate into one sheet in my consolidation file.
I have written macros to copy each sheet into the consolidation file, but I currently need to run it sheet by sheet as I don't know how to loop.
The copy macro sits in my Personal.xls file and the paste macro sits in the consolidation sheet.
The loop macro would need to work between the Source file (could be any name) and the consolidation file which is called Consolidation.xls.
Once all sheets are copied from a source file, I then open the next source file and start again, so macro would need to forget the old source file and remember the new one.
This could literally save me hours each week if I could get a macro to work, so any help much appreciated.
I think this is along the lines of what you are chasing. If all your templates are in a single folder, and each have a "start" and "end" sheet then this code will collate them into either
A new workbook with a unique sheet for each relevant sheet in each template
Into a single sheet in a new workbook
I have updated my code from "Collating worksheets from one or more workbooks into a summary file", http://www.experts-exchange.com/A_2804.html to cater for your "start" and "end" sheets
Please post if you need (or have) further detail
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:\"
'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 ws2.Index > Wb2.Sheets("start").Index And ws2.Index < Wb2.Sheets("end").Index Then
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
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
You should show us some code if you really want help.
But as far as I understood your question, here are some tips or links.
Code snippet to loop over worksheets
Dim wkbkorigin As Workbook
Dim ws As Worksheet
Set wkbkorigin = Workbooks.Open("C:\bookB.xls")
For Each ws In wkbkorigin.Worksheets
'do whatever
Next
Some stackoverflow threads about this issue
excel vba loop through worksheets and set values according to input
How can I loop through a subset of worksheets?
Some more tips about getting info from files
See this valuable thread: Copy data from another Workbook through VBA
You will find info about:
how to use the Excel object model to copy data from a file to another
using GetInfoFromClosedFile() function
Once you've defined workbooks/worksheets as per JMax response, I think you're looking for the following...
IncludeSheet=0
For n = 1 to wkbkOrigin.Worksheets.Count
If wkbkOrigin.Sheets(n).Name = "End" Then
IncludeSheet = 0
End If
If IncludeSheet = 1 Then
Set ws = wkbkOrigin.Sheets(n)
'do whatever
End If
If wkbkOrigin.Sheets(n).Name = "Start" Then
IncludeSheet = 1
End If
Next n
The key is to introduce a flag variable to tell you if you're in the right part of the workbook, in this case IncludeSheet