Code to allow user make range selection to search list in another workbook and return cell value - vba

Info
Workbook A: Has a master worksheet with a list of items, but the values are arranged in month columns
Workbook B: I have two sheets with different list of items I want to use to search Workbook A and return the current or specific month I need.
Note: Workbook B columns is offset, so we may need to account for this.
The code I have so far:
Sub Button()
Dim OpenFileName As String
Dim MyWB As Workbook, wb As Workbook
Dim aRange As Range
'Excel titled, "MODs", contains this module
Set MyWB = ThisWorkbook
'Ignore possible messages on a excel that has links
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
'Select and Open workbook
OpenFileName = Application.GetOpenFilename '("clients saved spreadsheet,*.xlsb")
If OpenFileName = "False" Then Exit Sub
Set wb = Workbooks.Open(OpenFileName)
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
If MsgBox("Please select list range to search.", vbExclamation, "Search List") = vbOK Then
On Error Resume Next
Set aRange = Application.InputBox(prompt:="Enter range", Type:=8)
If aRange Is Nothing Then
MsgBox "Operation Cancelled"
Else
aRange.Select
End If
End If
End Sub
I might might be making this harder than I should be, so I am open to suggestions. I can't seem to find the right find function to use my selected range list and target the newly open workbook with the specific master worksheet (something similar to a vlookup).
Version 2: with a set range but I'm still getting not value returns
Sub Button()
Dim OpenFileName As String
Dim MyWB As Workbook, wb As Workbook
Dim MyWs As Worksheet, ws As Worksheet
Dim aRange As Range
'This line of code turns off the screen updates which make the macro run much faster.
'Application.ScreenUpdating = False
'Excel titled, "MODs", contains this module
Set MyWB = ThisWorkbook
Set MyWs = MyWB.Sheets("Sheet")
'Ignore possible messages on a excel that has links
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
'Select and Open workbook
OpenFileName = Application.GetOpenFilename '("clients saved spreadsheet,*.xlsb")
If OpenFileName = "False" Then Exit Sub
Set wb = Workbooks.Open(OpenFileName)
On Error Resume Next
Set ws = Application.InputBox("Select a cell on the key sheet.", Type:=8).Parent
On Error GoTo 0
If ws Is Nothing Then
MsgBox "cancelled"
Else
MsgBox "You selected sheet " & ws.Name
End If
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
With MyWs
For Each aCell In .Range("A1:A10" & LastRow)
If Len(Trim(.Range("A19" & aCell.Row).Value)) <> 0 Then
.Cells(aCell.Row, 15) = Application.WorksheetFunction.VLookup( _
aCell.Value, ws.Range("A1:C18"), 2, 0)
End If
Next aCell
End With
'wb.Close (False)
'If MsgBox("Please select list range to search.", vbExclamation, "Search List") = vbOK Then
'On Error Resume Next
'Set aRange = Application.InputBox(prompt:="Enter range", Type:=8)
'If aRange Is Nothing Then
'MsgBox "Operation Cancelled"
'Else
'aRange.Select
'End If
'End If
'Return to default setting of screen updating.
'Application.ScreenUpdating = True
End Sub
I think the problem I'm running into is this code:
With MyWs
For Each aCell In .Range("A1:A10" & LastRow)
If Len(Trim(.Range("A19" & aCell.Row).Value)) <> 0 Then
.Cells(aCell.Row, 15) = Application.WorksheetFunction.VLookup( _
aCell.Value, ws.Range("A1:C18"), 2, 0)

begin declaringaCell as Range and lastRow as long
You seem to miss the definition of lastRow, which could be something like
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
then look carefully at .Range("A1:A10" & LastRow). Assume lastRow were 100 then this would set a range from A1 to A10100: is that what you want? Or may be you'd use
.Range("A1:A" & lastRow)
again .Range("A19" & aCell.Row) would lead to a single cell address such as "A1989" (were aCell.Row = 89): is that what you want?
other than what above I can't grasp the actual scenario of what you're searching where. You may want to provide more info about that

Related

Excel VBA For loop running too fast? Skipping delete row

Tried searching but nothing seems to specifically answer what I'm after..
For some reason it seems the code is running too fast and skipping the code within the IF section.
So far I've tried adding Application.Wait, creating a separate sub with the IF'd code to be called out in an effort to slow it down. Nothing has proved successful.
The basic purpose is to import a sheet, copy it to the active workbook, then delete rows which are red and finish by deleting the imported sheets.
Everything works except the red rows remain on the target sheet.
Stepping through the process with F8 yields a successful result!
Sub Grab_Data()
'FOR THE DEBUG TIMER
Dim StartTime As Double
Dim MinutesElapsed As String
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.DisplayAlerts = False
Dim targetWorkbook As Workbook
'Assume active workbook as the destination workbook
Set targetWorkbook = Application.ActiveWorkbook
'Import the Metadata
Dim sImportFile As String, sFile As String
Dim sThisBk As Workbook
Dim vfilename As Variant
Set sThisBk = ActiveWorkbook
sImportFile = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel Workbooks, *.xlsm; *.xlsx", Title:="Open
Workbook")
If sImportFile = "False" Then
MsgBox "No File Selected!"
Exit Sub
Else
vfilename = Split(sImportFile, "\")
sFile = vfilename(UBound(vfilename))
Application.Workbooks.Open Filename:=sImportFile
StartTime = Timer
Set wbBk = Workbooks(sFile)
With wbBk
'COPY TV SHOWS SHEET
If SheetExists("TV") Then
Set wsSht = .Sheets("TV")
wsSht.Copy after:=sThisBk.Sheets(Sheets.Count)
ActiveSheet.Name = "TV 2"
Else
MsgBox "There is no sheet with name :TV in:" & vbCr & .Name
End If
wbBk.Close SaveChanges:=False
End With
End If
Set wsSht = Nothing
Set sThisBk = Nothing
'#########TV##########
'Set sheets to TV
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets("TV")
Dim sourceSheet As Worksheet
Set sourceSheet = targetWorkbook.Worksheets("TV 2")
'Find Last Rows
Dim LastRow As Long
With sourceSheet
LastRow = .Cells(rows.Count, "A").End(xlUp).Row
End With
Dim LastRow2 As Long
With targetSheet
LastRow2 = .Cells(rows.Count, "C").End(xlUp).Row
End With
'Remove RED expired rows
With sourceSheet
For iCntr = LastRow To 1 Step -1
If Cells(iCntr, 2).Interior.ColorIndex = 3 Then
rows(iCntr).EntireRow.Delete
Debug.Print iCntr
End If
Next
End With
'Variables for TV
targetSheet.Range("B4:B" & LastRow).Value = sourceSheet.Range("E2:E" &
LastRow).Value
sourceSheet.Range("E2:E" & LastRow).Copy
targetSheet.Range("B4:B" & LastRow).PasteSpecial xlFormats
Set targetSheet = Nothing
Set sourceSheet = Nothing
'Delete imported sheets
With ActiveWorkbook
.Sheets("TV 2").Delete
.Sheets("Movies 2").Delete
.Sheets("Audio 2").Delete
End With
LastRow = Sheets("TV").Cells(rows.Count, "B").End(xlUp).Row
End With
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "This code ran successfully in " & MinutesElapsed & " minutes",
vbInformation
End Sub
Private Function SheetExists(sWSName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(sWSName)
If Not ws Is Nothing Then SheetExists = True
End Function
You have With sourceSheet but inside that block none of your range references are scoped to that With. eg
If Cells(iCntr, 2).Interior.ColorIndex = 3 Then
should be
If .Cells(iCntr, 2).Interior.ColorIndex = 3 Then
check all your other range references for similar issues.
Code which is not working as expected sometimes works when stepping through: this is often because the activeworkbook at any given point is different from when you run it straight through. That's why every range/sheet reference should be fully qualified to remove any ambiguity.
Application.Calculation = xlManual is your problem--functions and formatting aren't updating, so your if statement isn't firing properly.
Add Application.CalculateFull before the problem lines, and it should work.

How to stop internal links from turning to #REF?

I have a tab (Tab A) in my workbook that has links to another tab (Tab B and Tab C) that VBA inserts with Application.GetOpenFilename. When I run the macro I get #REF! in Tab A for the formulas on that tab (the formulas reference the inserted tabs ie Tab B and Tab C). How can I prevent this from happening and to keep the formulas on Tab A intact?
Here is my code:
Sub Data_Tab()
'
' Data Tab Macro
Dim ws As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("CC_DMSR").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "CC_DMSR"
Application.DisplayAlerts = True
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range
Set wb1 = ActiveWorkbook
Set PasteStart = [CC_DMSR!A1]
Sheets("CC_DMSR").Select
Cells.Select
Selection.ClearContents
MsgBox "Please select the CC DMSR File"
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a Report to Parse", _
FileFilter:="Report Files *.xlsx (*.xlsx),")
If FileToOpen = False Then
MsgBox "No File Specified.", vbExclamation, "ERROR"
Exit Sub
Else
Set wb2 = Workbooks.Open(Filename:=FileToOpen)
For Each Sheet In wb2.Sheets
With Sheet.UsedRange
.Copy PasteStart
Set PasteStart = PasteStart.Offset(.Rows.Count)
End With
Next Sheet
End If
wb2.Close
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Submitted_DMSR").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "Submitted_DMSR"
Application.DisplayAlerts = True
Set wb1 = ActiveWorkbook
Set PasteStart = [Submitted_DMSR!A1]
Sheets("Submitted_DMSR").Select
Cells.Select
Selection.ClearContents
MsgBox "Please select the Submitted DMSR File"
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a Report to Parse", _
FileFilter:="Report Files *.xlsx (*.xlsx),")
If FileToOpen = False Then
MsgBox "No File Specified.", vbExclamation, "ERROR"
Exit Sub
Else
Set wb2 = Workbooks.Open(Filename:=FileToOpen)
For Each Sheet In wb2.Sheets
With Sheet.UsedRange
.Copy PasteStart
Set PasteStart = PasteStart.Offset(.Rows.Count)
End With
Next Sheet
End If
wb2.Close
ActiveWorkbook.RefreshAll
ActiveSheet.PivotTables("PivotTable2").PivotCache.MissingItemsLimit = _
xlMissingItemsNone
ActiveSheet.PivotTables("PivotTable1").PivotCache.MissingItemsLimit = _
xlMissingItemsNone
With Sheets("Comparison").PivotTables("PivotTable1").PivotFields("TASK/TB")
.PivotItems("(blank)").Visible = False
End With
With Sheets("Comparison").PivotTables("PivotTable2").PivotFields("TASK/TB")
.PivotItems("(blank)").Visible = False
End With
Dim bottomrow As Long
Sheets("Comparison").Select
bottomrow = Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
Range("D4:J4").AutoFill Destination:=Range("D4:J" & bottomrow), Type:=xlFillDefault
Application.ScreenUpdating = True
Call sourceSheet.Activate
End Sub
I'm not sure if just opening wb2 is introducing the REF errors or the insertion of the sheets.
E.g.
If you open workbook1, which has a formula which contains a reference to workbook2, and workbook2 is then opened in Protected Mode (per default settings), Excel will introduce REF errors in any cells with references to workbook2 (due to Protected mode).
If the above is your problem, then one way might be to add wb2 as trusted document or location, or Excel>File>Options>And turn off protected mode (inadvisable).
Irrespective of the above, other solution is you using:
Range.Find and loop through all cells with references to the
sheet(s) that will be inserted
Temporarily replace the first '=' with ' =' in these cells, which should turn the formula into a string value.
You then insert the sheets you want (string values can't experience REF errors)
Then replace ' =' with '=' to convert string back to Excel formula.
You could set a range object in step 1 that could then be reused in step 2 and 3.

Copy row based on content and paste it in different sheets which are selected based on the content of the row

We've created a order sheet for all our machines, the main sheet is 'Order Sheet'.
And we're sending this sheet to the purchasing department at the end of the day.
When we run the macro to email the file, we wanted the macro to also copy each row to the specific machine worksheet. Eg. rows marked as 'Slicer' to go to the 'Slicer' sheet, 'blender' to 'blender', etc.
This is what I've got so far:
Sub PrintToNetwork()
ActiveWorkbook.Save
Range("A2:N25").Font.Size = 11
Dim OutApp As Object
Dim OutMail As Object
Dim answer As Integer
answer = MsgBox("Are you sure you want to Print & Send the sheet?", vbYesNo + vbQuestion, "Empty Sheet")
If answer = vbYes Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Retail Order Sheet"
.Body = "Hi Andy, Please order."
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Range("A1:N25").Select
ActiveSheet.PageSetup.PrintArea = "$A$1:$N$25"
oldprinter = Application.ActivePrinter
For i = 0 To 15
curNePrint = Format(i, "00")
On Error Resume Next
Application.ActivePrinter = "\\10.17.0.9\CCFN_Retail_MFP_BW on Ne" & curNePrint & ":"
Next i
ActiveWindow.Selection.PrintOut Copies:=1
Application.ActivePrinter = oldprinter
On Error GoTo 0
Else
End If
End Sub
Assuming the rows' location on the destination worksheet is determined by examining the same column as the one containing the worksheet names, something like the following might do the trick.
The DispatchRows sub scans prngWorksheetNames, looking for worksheets that exist by name.
You must call DispatchRows by passing it the range containing the worksheet names. For example, if the source worksheet names are on worksheet Summary, range C2:C50, you'd call DispatchRows ThisWorkbook.Worksheets("Summary").Range("C2:C50").
Option Explicit
'Copies entire rows to worksheets whose names are found within prngWorksheetNames.
'ASSUMPTION: on the destination worksheet, a copied row is appended at the lowest empty spot in the same column as prngWorksheetNames.
Public Sub DispatchRows(ByVal prngWorksheetNames As Excel.Range)
Dim lRow As Long
Dim rngWorksheetName As Excel.Range
Dim sDestWorksheetTabName As String
Dim oDestWs As Excel.Worksheet
Dim bScreenUpdating As Boolean
Dim bEnableEvents As Boolean
On Error GoTo errHandler
bScreenUpdating = Application.ScreenUpdating
bEnableEvents = Application.EnableEvents
Application.ScreenUpdating = False
Application.EnableEvents = False
For lRow = 1 To prngWorksheetNames.Rows.Count
Set rngWorksheetName = prngWorksheetNames.Cells(lRow, 1)
sDestWorksheetTabName = CStr(rngWorksheetName.Value)
If TryGetWorksheetByTabName(ThisWorkbook, sDestWorksheetTabName, oDestWs) Then
'Make sure there are no active autofilters on the destination worksheet, as they would typically interfere with the copy operation.
If oDestWs.FilterMode Then
oDestWs.ShowAllData
End If
'Copy and paste.
rngWorksheetName.EntireRow.Copy
oDestWs.Cells(oDestWs.Rows.Count, prngWorksheetNames.Column).End(xlUp).Offset(1).EntireRow.PasteSpecial xlPasteAll
End If
Next
Cleanup:
On Error Resume Next
Set rngWorksheetName = Nothing
Set oDestWs = Nothing
Application.CutCopyMode = False
Application.EnableEvents = bEnableEvents
Application.ScreenUpdating = bScreenUpdating
Exit Sub
errHandler:
MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
Resume Cleanup
End Sub
'Returns True, and a reference to the target worksheet, if worksheet psName is found by name on pwbkHost.
Public Function TryGetWorksheetByTabName(ByVal pwbkHost As Excel.Workbook, ByVal psName As String, ByRef pshtResult As Excel.Worksheet) As Boolean
Set pshtResult = Nothing
On Error Resume Next
Set pshtResult = pwbkHost.Worksheets(psName)
TryGetWorksheetByTabName = Not pshtResult Is Nothing
End Function
Here is very simple script to achieve what you want. Insert in your code appropriately, or call it from your macro. I tested this many times to make sure it works.
Sub CopyLines()
Dim mySheet
Dim LastRow As Long
Dim LastShtRow As Long
Dim j
LastRow = Sheets("Order Sheet").Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To LastRow Step 1
mySheet = Range("B" & j).Value
LastShtRow = Sheets(mySheet).Cells(Rows.Count, 1).End(xlUp).Row
Range("A" & j & ":" & "N" & j).Copy
Sheets(mySheet).Range("A" & LastShtRow + 1).PasteSpecial xlPasteValues
Next j
Application.CutCopyMode = False
End Sub

How to suppress excel large info on clipboard message

I am copying data from worksheet ws and am trying to paste just the values back to the original sheet, thus overwriting the original data with plain text. When I close the workbook I get an excel message telling me "There is a large amount of information on the clipboard. Do you want to be able to past this information into another program?" I will never want to do this. I don't want this message to not appear or assume the answer is "No".
Function FindPresenters(MyDate As Date, MyWS As String) As String
'MyDate is in format of 10/3/2016
'MyWS is the target worksheet to find MyDate
Dim GCell As Range
Dim xlApp As Object
Dim WB As Workbook
Dim WS As Worksheet
Dim MyLoop As Integer
Dim Found As Boolean
On Error GoTo ErrorHandler
Set xlApp = CreateObject("Excel.application") 'New Excel.Application
Application.ScreenUpdating = True
xlApp.Visible = True
Set WB = xlApp.Workbooks.Open ("Sched(Others).xlsx")
Set WS = WB.Worksheets("Oct 2016 Training Schedule")
With WS '.UsedRange
'.Cells.Select
.UsedRange.Select
.Cells.Copy
.Cells.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False 'This should suppress msg, but doesn't
.Range("B2").Select
End With
WS.Activate
Set GCell = WS.Cells.Find(MyDate)
Found = False
For MyLoop = 1 To MaxDayItems 'Find the entrees for the month
Debug.Print GCell.Offset(MyLoop, 0).Text
If Not Found And InStr(1, GCell.Offset(MyLoop, 0).Text, "C.O.") > 0 Then
'Found data
Found = True
FindPresenters = GCell.Offset(MyLoop, 0).Text
MyLoop = MaxDayItems + 1 'Terminate searching
End If
Next MyLoop
Done:
Application.DisplayAlerts = False 'Tried this to suppress the message
WB.Close True 'This is where the Clipboard error appears
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set WS = Nothing
Set WB = Nothing
xlApp.Quit
Set xlApp = Nothing
Exit Function
'Error Handling section.
ErrorHandler:
...
GoTo Done
End Function
Because the cells you are copying belong to xlApp (a separate instance of Excel.Application) you will need to make xlApp.CutCopyMode equal false.
xlApp.CutCopyMode = False
I agree with Comintern's comment "You're only pasting values - just write them directly"
It appears that you are simple replacing all the formulas on the worksheet with their values. This can be achieved by simply like this:
WS.UsedRange.Value = WS.UsedRange.Value

Macro to move tabs to a consolidated workbook instead of coping and pasting

I have this code that First checks if a workbook is in a particular folder and if yes it copies all the
worksheets in that file into the existing workbook.
I would like to modify to code below to do the following:
Instead of copying and pasting the content of each tab to a new workbook, i would like to move the whole
tab over to the new workbook without(Create another copy on the new workbook).. The goal is to be able to
move all the content. The issue with the current way of moving the data is that it doesn't bring over the
images
you can find the code here (Second Answer)
VBA to loop through a folder find a worksheet open it and move all tabs to another workbook
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 = True
'set default directory here if needed
strDefaultFolder = "G:\Operations\test\"
'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 & "\*401kk*.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
You can try the below code to copy the entire tab to the current workbook in the loops..
Sheets("Sheet1").Copy Before:=Workbooks("Book1").Sheets(1)