Copying looped data from one workbook and paste to another - excel

I have written this code, and it works when doing it from one sheet to another. (Same workbook). But when i loop through the rows from workbook to workbook i get "Run time error 9" Subscript out of range.
I've checked several times if the filenames are as stated in the code, and it doesn't seem to be the problem. Also if I in the first piece write y.sheets("Tavledisplay") instead of worksheets("Tavledisplay") the debugger tells me there's a problem there. Doing it the latter way, it sends 1 loop of data, and stops at y.sheets("Tavledisplay").Activate.
My code:
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Safecardmaster.xlsm")
Set y = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Tavleark1.xlsm")
a = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Tavledisplay").Cells(i, 14).Value = "Ja" Then
Worksheets("Tavledisplay").Rows(i).Select
Selection.Copy
x.Sheets("Løsninger").Activate
b = Worksheets("Løsninger").Cells(Rows.Count, 1).End(xlUp).Row
x.Sheets("Løsninger").Cells(b + 1, 1).Select
ActiveSheet.Paste
y.Sheets("Tavledisplay").Activate
Selection.ClearContents
End If
Next i
Application.CutCopyMode = False
x.Sheets("Løsninger").Select
I expect the code to loop through all the given rows, where there is a "Ja" in column 14, and pasting them into my other workbook sheet "Løsninger" and deleting them from the other workbook.

You don't need to loop through each loop, a simple filter will do the trick:
Option Explicit
Sub Test()
Dim x As Workbook
Dim y As Workbook
Dim CopyRange As Range
Dim LastRow As Long
Set x = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Safecardmaster.xlsm")
Set y = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Tavleark1.xlsm")
'Look for the range to copy and set it
With y.Worksheets("Tabledisplay")
.UsedRange.AutoFilter Field:=14, Criteria1:="Ja"
LastRow = .Cells(.Rows.Count, 14).End(xlUp).Row
Set CopyRange = .Range("A2", .Cells(LastRow, .UsedRange.Columns.Count)).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
'Paste it to the other sheet
With x.Worksheets("Løsninger")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
CopyRange.Copy .Cells(LastRow, 1)
End With
'Delete the range from the original sheet
CopyRange.Delete
End Sub

Related

Excel VBA Looping through Worksheets and Copy Paste into a different Worksheet

I am new to VBA and I am trying to write some code to copy data from one worksheet to another one. I have checked various sites and tried to write the code, but until I always get an error. The setting is as follows:
I have various worksheets, most of them are worksheets based on different teams (I will call them Team-Worksheets), one sheet is the data I import from an external databank (I will call it Import-Worksheet).
The code should loop through all the Team-Worksheets and based on the Name of the Team, which is always located in Cell “A2” it should find all stories that belong to the team in the “Import-Worksheet”(comparing it with “Team Name Column”) and ONLY copy the “ID” located in the “ID Column” and paste it into the second row of “ID Column” of the ListObject 1 of the corresponding "Team-Worksheet". Then it should find the next ID of that Team in the “Import-Worksheet” and copy-paste it into the next row of ListObject 1(all sheets have multiple listobjects, with varying length and start points). After it went through all the rows it should continue with the next “Team-Worksheet”.
I am unsure if I should run a 1) "for-loop" + "for-loop" 2) “for-loop” + an “advanced-filter”, or 3) “for-loop” + “for-loop combined with index/match”?
I used if B4 = Epic Id Link as I don't want to apply this to all the worksheets
Example 1:
Sub AddContent()
Dim sht As Worksheet
Dim i As Variant
Dim x As Long
Dim y As Worksheet
Dim rw As Range
Application.ScreenUpdating = False
For Each sht In ThisWorkbook.Worksheets
sht.Activate
i = sht.Range("A2")
Set y = ActiveSheet
If sht.Range("B4").Value = "EPIC ID Link" Then
Sheets("Jira Import").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 5 To FinalRow
' Decide if to copy based on column D
ThisValue = Cells(x, 19).Value
If ThisValue = i Then
Cells(x, 4).Copy
y.ListObjects(1).ListColumns("US ID").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Jira Import").Select
End If
Next x
End If
Next sht
Application.ScreenUpdating = True
End Sub
Example 2:
Sub AddContent()
Dim sht As Worksheet
Dim i As Variant
Dim rgData As Range, rgCriteria As Range, rgOutput As Range
Application.ScreenUpdating = False
For Each sht In ThisWorkbook.Worksheets
sht.Activate
Set i = ActiveSheet.Range("A2")
If sht.Range("B4").Value = "EPIC ID Link" Then
Set rgData = ThisWorkbook.Worksheets("Jira Import").Range("S5").CurrentRegion
Set rgCriteria = i
Set rgOutput = ActiveSheet.ListObjects(1).ListColumns("US ID").DataBodyRange
rgData.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rgOutput, Unique:=True
End If
Next sht
Application.ScreenUpdating = True
End Sub
Solving this would save me plenty of manual work!

VBA Does not copy the entire row, missing one column

a bit of an odd one. I have a file with large amount of info that goes up to column "CH". Information in the workbook is spread through multiple tabs and when I consolidate data it copies everything except for the last column. Wonder if you could help me with that
Sub consolidation()
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidation").Delete
Application.DisplayAlerts = True
With ActiveWorkbook
Set Destination = .Sheets.Add(After:=.Sheets(.Sheets.Count))
Destination.Name = "Consolidation"
End With
Dim i As Integer
Dim stOne As Worksheet
Dim stOneLastRow As Long
Dim stTwo As Worksheet
Dim stTwoLastRow As Long
Dim consolid As Worksheet
Dim consolidLastRow As Long
Set stOne = ThisWorkbook.Sheets("Sheet1")
Set stTwo = ThisWorkbook.Sheets("Sheet2")
Set consolid = ThisWorkbook.Sheets("Consolidation")
stOneLastRow = stOne.Range("C" & Rows.Count).End(xlUp).Row
stTwoLastRow = stTwo.Range("C" & Rows.Count).End(xlUp).Row
consolidLastRow = consolid.Range("C" & Rows.Count).End(xlUp).Row
For i = 6 To stOneLastRow
stOne.Select
If stOne.Range("C6").Value = "OM ID" Then
Cells(i, 3).Resize(1, 100).Copy
consolid.Select
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(NextRow, 2).Select
ActiveSheet.Paste
stOne.Select
End If
Next i
For i = 7 To stTwoLastRow
stTwo.Select
If stTwo.Range("C6").Value = "OM ID" Then
Cells(i, 3).Resize(1, 100).Copy
consolid.Select
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(NextRow, 2).Select
ActiveSheet.Paste
stTwo.Select
End If
Next i
End Sub
Initial code is taken from here: https://learn.microsoft.com/en-us/office/vba/api/excel.range.copy
Tried to copy rows based on the value in CH cell, but still copies everything except for that column...
Very weird :-(
Omg... I feel so stupid. The data starts from 3rd column, but I copied everything starting from the 2nd colum... macro works correctly, just needed to change the column...

Copy data into different named multiple sheets

Dears,
I am a beginner and tried to prepare the macro that enables firstly delete rows based on condition, than create new sheets based on criteria from the first main sheet and add data from the first main sheet into multiple named sheets.
deletes rows based on condition (RUNs OK)
creates new sheets based on criteria from the first main sheet (RUNs OK)
adds data from the first main sheet (constant range I4:I6)
into multiple named sheets to A1:A3 in all of them (being created by this macro). Unfortunately I do not know how to do that :-(
Could you possibly help me, please?
Private Sub CommandButton1_Click()
Dim lastrow As Long, x As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For x = lastrow To 1 Step -1
If UCase(Cells(x, 3).Value) = "0" And _
UCase(Cells(x, 6).Value) = "0" Then
Rows(x).Delete
End If
Next
lastcell = ThisWorkbook.Worksheets("Obratova predvaha").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastcell
With ThisWorkbook
newname = ThisWorkbook.Worksheets("Obratova predvaha").Cells(i, 1).Value
.Sheets.Add after:=.Sheets(.Sheets.Count)
ActiveSheet.Name = newname
End With
Next
ThisWorkbook.Worksheets("Obratova predvaha").Activate
ThisWorkbook.Worksheets("Obratova predvaha").Cells(1, 1).Select
End Sub
not very sure about your description, but you may try this:
edited to add a sheet variable and prevent any (possible?) time lapse misbehavior between new sheet adding and writing to it by implicitly assuming it as ActiveSheet:
Option Explicit
Private Sub CommandButton1_Click()
Dim lastrow As Long, i As Long
Dim newSheet As Worksheet
With Worksheets("Obratova predvaha")
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = lastrow To 1 Step -1
If UCase(.Cells(i, 3).Value) = "0" And UCase(.Cells(i, 6).Value) = "0" Then .Rows(i).Delete
Next
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
Set newSheet = Sheets.Add(after:=Sheets(Sheets.Count)) ' add a new sheet and hold its reference in newSheet variable
newSheet.Range("A1:A3").Value = .Range("I4:I6").Value ' copy referenced sheet I4:I6 values into newly added sheet cells A1:A3
newSheet.Name = .Cells(i, 1).Value ' change the name of newly added sheet
Next
End With
End Sub

VBA Runtime Error 1004 on Range.Clear

There are a lot of threads about this error, but I can't get this to work no matter what I try. Most people say it occurs when you try to invoke a method on an inactive sheet, but you shouldn't have to do that. Error is on line 28. Thanks.
Private Sub CommandButton1_Click()
Dim x As Integer
Dim boisePaste As Integer
Dim jrgPaste As Integer
Dim master As Integer
Dim lastRow As Integer
Dim bookCount As Integer
bookCount = Application.Workbooks.Count
For x = 1 To bookCount
If Left(Application.Workbooks(x).Name, 14) = "ITEM_INVENTORY" Then
boisePaste = x
ElseIf Left(Application.Workbooks(x).Name, 6) = "report" Then
jrgPaste = x
ElseIf Left(Application.Workbooks(x).Name, 8) = "Portland" Then
master = x
End If
next x
'Unhide sheets and delete Boise range'
Application.ActiveWorkbook.Sheets("BoisePaste").Visible = True
Sheets("JRGpaste").Visible = True
lastRow = Sheets("BoisePaste").Cells(Rows.Count, "B").End(xlUp).Row
Sheets("BoisePaste").Range(Cells(1,2), Cells(lastRow, 23)).Clear
'Open Boise file and copy range, paste in master'
Application.Workbooks(boisePaste).Activate
With ActiveSheet
.Range(.Cells(1,1), .Cells((.Cells(Rows.Count, "A").End(xlUp).Row),22)).Copy
End With
Application.Workbooks(master).Sheets("BoisePaste").Range(B1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Open JRG report and copy range, paste in master'
Application.Workbooks(jrgPaste).Activate
ActiveSheet.Cells.Copy
Application.Workbooks(master).Sheets("JRGpaste").Range(A1).Paste
Application.CutCopyMode = False
'Refresh pivot tables; hide sheets'
Application.Workbooks(master).Activate
With ActiveWorkbook
.RefreshAll
.RefreshAll
.Sheets("BoisePaste").Visible = False
.Sheets("BoisePaste").Visible = False
End With
End Sub
You need to explicitly state which sheet you want the Rows.Count and other such Range uses (Columns,Rows,Cells,etc.) will be on.
Try this:
Sheets("BoisePaste").Range(Sheets("BoisePaste").Cells(1,2), Sheets("BoisePaste").Cells(lastRow, 23)).Clear
So, go through your code and make sure you do this everywhere...i.e. in .Range(.Cells(1,1), .Cells((.Cells(Rows.Count, "A").End(xlUp).Row),22)).Copy, you didn't do it to Rows.Count, so add the sheet there too, to prevent any unexpected actions.
Think of it like this perhaps, with the line
myVariable = Sheets("mySheet").Range(Cells(1,1),Cells(1,2)).Value
VBA is reading that as
In mySheet, look for a range. What range? Hm, the user says Cells(1,1) and Cells(1,2), but what sheet does he want that? The current activesheet is called yourSheet...He specified where the Range should be (sheet called mySheet), but he didn't on Cells(), so I don't know what he wants! mySheet cells(1,1) or yourSheet cells(1,1) ??
(and yes, that's exactly how a computer thinks :P)
Edit: I went through and tried to help tighten up your code. But, as you can see perhaps, I'm not quite positive as to what you want to do, but this should give you some help/insight:
Private Sub CommandButton1_Click()
Dim x As Integer
Dim boisePaste As Integer
Dim jrgPaste As Integer
Dim master As Integer
Dim lastRow As Integer
Dim bookCount As Integer
bookCount = Application.Workbooks.Count
' Create variables to hold the workbook and sheet names.
Dim jrgWS As Worksheet, boiseWS As Worksheet
Dim masterWB As Workbook
Set masterWB = Workbooks(master)
Set jrgWS = Sheets("JRGPaste")
Set boiseWS = Sheets("BoisePaste")
For x = 1 To bookCount
If Left(Application.Workbooks(x).Name, 14) = "ITEM_INVENTORY" Then
boisePaste = x
ElseIf Left(Application.Workbooks(x).Name, 6) = "report" Then
jrgPaste = x
ElseIf Left(Application.Workbooks(x).Name, 8) = "Portland" Then
master = x
End If
Next x
'Unhide sheets and delete Boise range'
Application.ActiveWorkbook.Sheets("BoisePaste").Visible = True
jrgWS.Visible = True
With boiseWS
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range(.Cells(1, 2), .Cells(lastRow, 23)).Clear
End With
'Open Boise file and copy range, paste in master'
'' DONT USE ACTIVE SHEET! Use your variables instead
'Application.Workbooks(boisePaste).Activate
With boiseWS
'Since you want values (xlPasteValues), just set the two ranges equal instead of copy/paste
.Range("B1").Value = .Range(.Cells(1, 1), .Cells((.Cells(.Rows.Count, "A").End(xlUp).Row), 22)).Value
End With
'Open JRG report and copy range, paste in master'
' The below just pastes into the same sheet, no??
jrgWS.Cells.Copy
jrgWS.Range("A1").Paste
Application.CutCopyMode = False
'Refresh pivot tables; hide sheets'
Application.Workbooks(master).Activate
With ActiveWorkbook
.RefreshAll
.RefreshAll
.Sheets("BoisePaste").Visible = False
End With
End Sub

If Condition to create sheets only when Auto filter has data

I have written a code which does the below steps.
1) Loops through a list of products
2) Auto filters the data with each product.
3) Copies and pastes data on to separate worksheets and names it with that product name.
4) Inserts a line at every change in schedule
The only thing I couldn't do it here is to limit separate worksheet creation only for the products available in the source data when auto filtered.
I tried to do this by adding an if condition to add worksheets by product name only if auto filter shows any data but for some reason it is not working.
I would appreciate any help in fixing this problem and clean my code to make it look better and work faster.
Sub runreport()
Dim rRange As Range
Dim Rng As Range
' Open the Source File
Filename = Application.GetOpenFilename()
Workbooks.Open Filename
'Loops through each product type range from the macro spreadsheet.
For Each producttype In ThisWorkbook.Sheets("Schedule").Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
Sheets("Sheet1").Select
Sheets("Sheet1").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
'Names the worksheet by Prod type descreption doing a vlookup from the spreadsheet
ActiveSheet.Name = Application.VLookup(producttype, ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
'This will paste the filtered data from Source Data to the new sheet that is added
Range("a2").Select
ActiveSheet.Paste
ns = ActiveSheet.Name
'Copeis the headers to all the new sheets
Sheets("Sheet1").Select
Range("A1:BC1").Select
Selection.Copy
Sheets(ns).Activate
Range("a1").Select
ActiveSheet.Paste
Columns.AutoFit
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
Next producttype
End Sub
Try this...
Sub runreport()
Dim rRange As Range
Dim Rng As Range
Dim FiltRows As Integer
' Open the Source File
Filename = Application.GetOpenFilename()
Workbooks.Open Filename
'Loops through each product type range from the macro spreadsheet.
For Each producttype In ThisWorkbook.Sheets("Schedule").Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
With Workbooks("Source.xlsx").Sheets("Sheet1")
FiltRows = .AutoFilter.Range.Rows.SpecialCells(xlCellTypeVisible).Count / .AutoFilter.Range.Columns.Count
End With
If FiltRows > 1 Then 'There will always be a header row which is why it needs to be greater than one.
Sheets("Sheet1").Select
Sheets("Sheet1").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
'Names the worksheet by Prod type descreption doing a vlookup from the spreadsheet
ActiveSheet.Name = Application.VLookup(producttype, ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
'This will paste the filtered data from Source Data to the new sheet that is added
Range("a2").Select
ActiveSheet.Paste
ns = ActiveSheet.Name
'Copeis the headers to all the new sheets
Sheets("Sheet1").Select
Range("A1:BC1").Select
Selection.Copy
Sheets(ns).Activate
Range("a1").Select
ActiveSheet.Paste
Columns.AutoFit
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
End If
Next producttype
End Sub
I would recommend you define more variables than you have it keeps the code cleaner and easier to read as well as eliminates easy errors.
I also recommend always to utilize "option explicit" at the top of every code. It forces defining all variables (when you don't define a variable the program will do it for you (assuming you haven't used option explicit), but excel doesn't always get it correct. Also option explicit helps you avoid typos in variables.
Also as a general rule you rarely if ever have to .select anything to do what you need to with vba.
Below is an example of a cleaned up and shortened code which utilized variable definition and instantiation.
Sub runreport()
Dim wb As Workbook
Dim wsSched As Worksheet
Dim wsNew As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rRange As Range
Dim producttype As Range
Dim Filename As String
Dim FiltRows As Integer
Dim myRow As Integer
'instantiate Variables
Set wb = ThisWorkbook
Set wsSched = wb.Worksheets("Schedule")
' Open the Source File
Filename = Application.GetOpenFilename()
Set wbSource = Workbooks.Open(Filename)
Set wsSource = wbSource.Worksheets("Sheet1")
'Loops through each product type range from the macro spreadsheet.
For Each producttype In wsSched.Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
With wsSource
.AutoFilterMode = False
.Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
FiltRows = .AutoFilter.Range.Rows.SpecialCells(xlCellTypeVisible).Count / .AutoFilter.Range.Columns.Count
If FiltRows > 1 Then 'There will always be a header row which is why it needs to be greater than one.
'Add new workbook
Set wsNew = wb.Sheets.Add(After:=ActiveWorkbook.Sheets(Sheets.Count))
'Copy filtered data including header
.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
'Paste filterd data and header
wsNew.Range("A1").PasteSpecial
Application.CutCopyMode = False
wsNew.Columns.AutoFit
'Rename new worksheet
wsNew.Name = WorksheetFunction.VLookup(producttype, wb.Worksheets("Sheet2").Range("A:B"), 2, False)
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
End If
End With
Next producttype
End Sub
First, you can check this answer for ways to optimize your vba code
As for your code in its current form, it would be easiest if you select the entire range of your product code data first. Then you can check this range after your filter and determine if all the rows are hidden. See a sample of the code below
Dim productData as Range
Set productData = Range(Range("A2"), Range("A2").End(xlDown).End(xlToRight))
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter _
Field:=4, Criteria1:=producttype
' The error check will skip the creation of a new sheet if the copy failed (i.e. returns a non-zero error number)
On Error Resume Next
' Copies only the visible cells
productData.SpecialCells(xlCellTypeVisible).Copy
If Err.number = 0 then
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
ActiveSheet.Name = Application.VLookup(producttype, _
ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
Range("a2").Select
ActiveSheet.Paste
End If
While you can Range.Offset one row and check if the Range.SpecialCells method with xlCellTypeVisible is Not Nothing, I prefer to use the worksheet's SUBTOTAL function. The SUBTOTAL function discards hidden or filtered rows from its operations so a simple COUNTA (SUBTOTAL subfunction 103) of the cells below the header will tell you if there is anything available.
Sub runreport()
Dim rRange As Range, rHDR As Range, rVAL As Range, wsn As String
Dim fn As String, owb As Workbook, twb As Workbook
Dim i As Long, p As Long, pTYPEs As Variant
pTYPEs = ThisWorkbook.Sheets("Schedule").Range("Product").Value2
Set twb = ThisWorkbook
' Open the Source File
fn = Application.GetOpenFilename()
Set owb = Workbooks.Open(fn)
With owb
'is this Workbooks("Source.xlsx")?
End With
With Workbooks("Source.xlsx").Worksheets("Sheet1")
With .Cells(1, 1).CurrentRegion
'store the header in case it is needed for a new worksheet
Set rHDR = .Rows(1).Cells
'reset the the filtered cells
Set rVAL = Nothing
For p = LBound(pTYPEs) To UBound(pTYPEs)
.AutoFilter Field:=4, Criteria1:=pTYPEs(p)
With .Resize(.Rows.Count - 1, 7).Offset(1, 0) '<~~resize to A:G and move one down off the header row
If CBool(Application.Subtotal(103, .Cells)) Then
'there are visible cells; do stuff here
Set rVAL = .Cells
wsn = Application.VLookup(pTYPEs(p), twb.Worksheets("Sheet2").Range("A:B"), 2, False)
'if the wsn worksheet doesn't exist, go make one and come back
On Error GoTo bm_New_Worksheet
With Worksheets(wsn)
On Error GoTo bm_Safe_Exit
rVAL.Copy Destination:=.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
'when inserting rows, always work from the bottom to the top
For i = .Cells(Rows.Count, 3).End(xlUp).Row To 3 Step -1
If .Cells(i, 3).Value2 <> .Cells(i - 1, 3).Value2 Then
.Rows(i).Insert
End If
Next i
'autofit the columns
For i = .Columns.Count To 1 Step -1
.Columns(i).AutoFit
Next i
End With
End If
End With
Next p
End With
End With
GoTo bm_Safe_Exit
bm_New_Worksheet:
On Error GoTo 0
With Worksheets.Add(after:=Sheets(Sheets.Count))
.Name = wsn
rHDR.Copy Destination:=.Cells(1, 1)
End With
Resume
bm_Safe_Exit:
End Sub
When a worksheet that is referenced by the wsn string does not exist, the On Error GoTo bm_New_Worksheet runs off and creates one. The Resume brings the code processing right back to the place it errored out.
One caution when using this method is to ensure that you have unique, legal worksheet names returned by your VLOOKUP function.

Resources