Print same worksheet multiple times in one job - vba

I am attempting to print the same worksheet multiple times as one print job. I have a worksheet that has a table with columns ID, FirstName, LastName, and Age. I have another worksheet that acts like a form.
Users select an ID and the rest of the columns get automatically populated (First Name, LastName, and Age).
I already have code that once the user selects which ID they want from a dropdown, the sheet updates with the information for that ID automatically.
I am trying to add a macro that will print the same worksheet for each ID. So if I had 2 id's for example:
the code will use my existing macro to update the worksheet with ID1
print the worksheet
use my code to update the worksheet with ID2
print the worksheet
In the end though, I would like to have one print job that has both sheets in it.
I already know I could use the below code to print the worksheets separate:
Sub PrintForms()
dim myID as integer
'myID gets the last ID numer
myID = sheets("CondForm").Range("A1").Value
for i = 1 to myID
'this just takes the ID number from i and updates the worksheet with the data for that id
call misc.UpdateSheet(i)
Sheets("Data Form").PrintOut
Next i
End Sub
But I need all of the prints to come out as one print job so that if they chose pdf for example it gets printed as one pdf document and not hundreds.
I also found this method that will print an array of sheets, but it still doesn't let me update the sheet between prints.
Sub PrintArray()
Dim SheetsToPrint As String
Dim MyArr() As String
SheetsToPrint = "Data Table,Data Form"
'Split the string into an array
MyArr = Split(SheetsToPrint, ",")
ThisWorkbook.Worksheets(MyArr).PrintOut
End Sub

try this - adjust the original data - I assumed different records every 20 rows in this code.
Sub testit()
Dim ws As Worksheet, lastRow As Long, originalWS As Worksheet
Dim originalRowCounter As Long, wsRowCounter As Long, numberRecords As Long
Dim i As Long
Application.ScreenUpdating = False
Set originalWS = ActiveSheet
Set ws = Sheets.Add
originalRowCounter = 1
wsRowCounter = 1
originalWS.Activate
' Assume every 20 rows on originalWS has idividual record - adjust this accordingly
lastRow = originalWS.Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).Row + 1
numberRecords = lastRow / 20
For i = 1 To numberRecords
originalWS.Range("A" & originalRowCounter & ":K" & (originalRowCounter + 19)).Select
Selection.Copy
ws.Activate
ws.Range("A" & wsRowCounter).Activate
ActiveSheet.Paste
originalRowCounter = originalRowCounter + 20
wsRowCounter = wsRowCounter + 20
ws.Rows(wsRowCounter).PageBreak = xlPageBreakManual
originalWS.Activate
Next i
Application.PrintCommunication = False
With ws.PageSetup
.FitToPagesWide = 1
.FitToPagesTall = False
End With
Application.PrintCommunication = True
ws.PrintOut
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set originalWS = Nothing
Set ws = Nothing
End Sub

Related

Nested If statement to cut & paste rows to different worksheet

Could someone help with this code?
I'm comparing two workbooks. I've built a For loop to check to see if the unique ids in workbook1 match the ids in workbook2.
If they match I'm assigning the returned row # to variable lrow. I then need to check the value in column C for the returned row.
Depending on the value in lrow, column C I need to cut the row in workbook1, sheet1 and paste to different sheets in workbook1. I also
need to delete the row that was cut so I dont have blank rows when done.
I'm getting a syntax error on the nested Else If statements. They are all highlighted in red. I'm also getting a Compile error on
these lines that says "Must be first statement on the line".
Could you let me know what I'm missing with the nested if and also verify if my cut and paste operation is valid.
Thanks for your assistance.
Option Explicit
Sub Complete()
Dim Lastrow, Newrow As Long
Dim i, lrow As Long
Dim wb1, wb2 As Workbook
Dim ws1, ws2 As Worksheet
' Turn off notifications
Application.ScreenUpdating = False
Workbooks.OpenText Filename:="C:\workbook2.xlsx"
Set wb1 = ThisWorkbook
Set wb2 = Workbooks("workbook2.xlsx")
Set ws1 = wb1.Worksheets("Sheet1")
Set ws2 = wb2.Worksheets("Sheet1")
With wb1.Worksheets(ws1)
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To Lastrow
If Not IsError(Application.Match(.Cells(i, "G").Value, ws2.Columns("A"), 0)) Then
lrow = Application.Match(.Cells(i, "G").Value, ws2.Columns("A"), 0)
If ws2.Cells(lrow,"C") = 18 Then
Newrow = wb1.Worksheets("Sheet3").Range("A1").End(xlDown).Row + 1
ws1.Cells(i,"G").EntireRow.Cut wb1.Worksheets("Sheet3").Cells(newrow,"A")
ws1.Cells(i,"G").EntireRow.Delete
ElseIf ws2.Cells(lrow,"C") = 23 Then
Newrow = wb1.Worksheets("Sheet4").Range("A1").End(xlDown).Row + 1
ws1.Cells(i,"G").EntireRow.Cut wb1.Worksheets("Sheet4").Cells(newrow,"A")
ws1.Cells(i,"G").EntireRow.Delete
ElseIf ws2.Cells(lrow,"C") = 24 Then
Newrow = wb1.Worksheets("Sheet4").Range("A1").End(xlDown).Row + 1
ws1.Cells(i,"G").EntireRow.Cut wb1.Worksheets("Sheet4").Cells(newrow,"A")
ws1.Cells(i,"G").EntireRow.Delete
ElseIf ws2.Cells(lrow,"C") = 36 Then
Newrow = wb1.Worksheets("Sheet5").Range("A1").End(xlDown).Row + 1
ws1.Cells(i,"G").EntireRow.Cut wb1.Worksheets("Sheet5").Cells(newrow,"A")
ws1.Cells(i,"G").EntireRow.Delete
End If
End If
Next i
End With
Workbooks("workbook2.xlsx").Close savechanges:=False
' Turn on notifications
Application.ScreenUpdating = True
' Message Box showing that process is complete.
MsgBox "Done!"
End Sub
From the last comment I made to #paulbica I corrected the line to read:
If Not IsError(Application.Match(.Cells(i, "G").Value, ws2.Columns("A"), 0)) Then
The code now runs correctly. I've update the post to reflect the changes made.
Thanks.
It's good that you solved the Type mismatch error, but there are a couple of issues left
The line With wb1.Worksheets(ws1) will throw another Type mismatch error because the Worksheets function takes the sheet name or index as an argument and ws1 is a Worksheet object, so it should be changed to With wb1.Worksheets(ws1.Name) or simply With ws1
The loop implemented like that will skip rows if they are contiguous. For example, if you start with a total of 5 rows, all of which need to be moved, in the first iteration i is 2 and row 2 will be deleted. Next iteration row 3 had become row 2 after deletion, but i is now 3, so the initial row 3 is skipped and processing moves to current row 3 which previously was 4
Depending on how much data you have your code is quite slow because it interacts with the ranges very often. For example it's extracting the value of ws2.Cells(lrow,"C") for every If branch, extracting the last row in sheets 3, 4, and 5 for every cut operation, and deleting rows one at the time
This is how I'd write the code:
Option Explicit
Public Sub Complete()
Dim i As Long, toDel As Range, copyCell As Range
Dim ws11 As Worksheet, ws13 As Worksheet, ws14 As Worksheet, ws15 As Worksheet
Dim ws13LR As Long, ws14LR As Long, ws15LR As Long
Dim wb2 As Workbook, ws21 As Worksheet, wb2row As Variant, wb2colA As Variant
Application.ScreenUpdating = False
Workbooks.OpenText Filename:="C:\workbook2.xlsx"
Set wb2 = Workbooks("workbook2.xlsx")
Set ws11 = Sheet1
Set ws13 = Sheet3: ws13LR = ws13.Cells(ws13.Rows.Count, 1).End(xlUp).Row + 1
Set ws14 = Sheet4: ws14LR = ws14.Cells(ws14.Rows.Count, 1).End(xlUp).Row + 1
Set ws15 = Sheet5: ws15LR = ws15.Cells(ws15.Rows.Count, 1).End(xlUp).Row + 1
Set ws21 = wb2.Sheets(1): wb2colA = ws21.UsedRange.Columns("A").Value2
For i = 2 To ws11.Cells(ws11.Rows.Count, 1).End(xlUp).Row + 1
wb2row = Application.Match(ws11.UsedRange.Cells(i, "G").Value, wb2colA, 0)
If Not IsError(wb2row) Then
Set copyCell = Nothing
Select Case ws21.Cells(wb2row, "C").Value2
Case 18: Set copyCell = ws13.Cells(ws13LR, "A"): ws13LR = ws13LR + 1
Case 23, 24: Set copyCell = ws14.Cells(ws14LR, "A"): ws14LR = ws14LR + 1
Case 36: Set copyCell = ws15.Cells(ws15LR, "A"): ws15LR = ws15LR + 1
End Select
If Not copyCell Is Nothing Then
With ws11.UsedRange
.Rows(i).EntireRow.Copy copyCell
If toDel Is Nothing Then
Set toDel = .Rows(i)
Else
Set toDel = Union(toDel, .Rows(i))
End If
End With
End If
End If
Next i
wb2.Close False
toDel.EntireRow.Delete
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
I moved all unnecessary operations out of the For loop, and created a new range of rows to be deleted at the end, in one operation

Copy and past with matching

I need to use a macro that will copy and paste an entire row based on whether the text of a cell matches another. I looked for something similar on the site but was not able to find something that could help. I'll outline the process I am trying to do:
Copy and paste a list of program names (the number of names can vary) from one sheet to another. (this one I have already completed)
Check each program name (number of programs can vary) individually to see if it matches a separate list on a separate sheet.
If it matches, copy and paste the entire row, if it doesn't, move to the next.
I tried using if and then statements, but I was having issues trying to loop it (if thats the correct term). The size of the list can vary, so making sure that this is taking into account in the macro is important. Here is what I have so far:
Copy and paste the initial list function
Sub Report_P1()
Dim wsPivot As Worksheet: Set wsPivot = ThisWorkbook.Sheets("Pivot")
Dim wsReport As Worksheet: Set wsReport = ThisWorkbook.Sheets("Report")
wsPivot.Select
Range("A4", Range("A65536").End(xlUp)).Select
Application.CutCopyMode = False
Selection.Copy
wsReport.Select
Range("A3").Select
ActiveSheet.Paste
End Sub
The filter tool I need help with
Sub Report_P2()
Dim i As Integer
Dim j As Integer
Dim wsReport As Worksheet: Set wsReport = ThisWorkbook.Sheets("Report")
Dim wsData As Worksheet: Set wsData = ThisWorkbook.Sheets("Data")
For i = 1 To 10
If wsReport.Cells(i, 1) = wsData.Cells(i, 1) Then
wsData.Select
Range(i).Select
'Application.CutCopyMode = False
Range(i).Copy
wsReport.Select
Range(i).Select
ActiveSheet.Paste
End If
Next i
End Sub
Thank you for your help!
Sub Report_P2()
Dim i As Integer
Dim j As Integer
Dim wsReport As Worksheet: Set wsReport = ThisWorkbook.Sheets("Report")
Dim wsData As Worksheet: Set wsData = ThisWorkbook.Sheets("Data")
For i = 1 To 10
If wsReport.Cells(i, 1) = wsData.Cells(i, 1) Then
wsData.Select
Rows(i).Select
Selection.Copy
wsReport.Activate
Range("A" & i).Activate
ActiveSheet.Paste
End If
Application.CutCopyMode = False
Next i
End Sub
Or more concisely:
For i = 1 To 10
If wsReport.Cells(i, 1) = wsData.Cells(i, 1) Then
wsData.Rows(i).Copy Destination:=wsReport.Range("A" & i)
End If
Next i

Ideas to make this code more efficient

I have a worksheet that lists a persons name (column A) with associated data (columns B through G). I have code below that takes this list of a ~ 1000 rows that
A.) First copies and pastes each row three times (to create four identical rows for each entry) then
B.) Loops through the now ~4000 rows and creates a new worksheet for each person.
As there are many duplicate names in column A this only creates ~ ten new worksheets
The thing is, it runs but runs quite slowly (and I receive the Excel not responding warning at times). Is there anything to clean this up to make it more efficient? And after this I run another macro to save the new worksheets to a new workbook. Would it be faster to do that with code here?
Sub Split_Data()
'This will split the data in column A out by unique values
Const NameCol = "A"
Const HeaderRow = 1
Const FirstRow = 2
Dim SrcSheet As Worksheet
Dim TrgSheet As Worksheet
Dim SrcRow As Long
Dim LastRow As Long
Dim TrgRow As Long
Dim person As String
Dim lRow As Long
Dim RepeatFactor As Variant
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Add four rows
lRow = 2
Do While (Cells(lRow, "B") <> "")
RepeatFactor = 4
Range(Cells(lRow, "A"), Cells(lRow, "G")).Copy
Range(Cells(lRow + 1, "A"), Cells(lRow + RepeatFactor - 1, "G")).Select
Selection.Insert Shift:=xlDown
lRow = lRow + RepeatFactor - 1
lRow = lRow + 1
Loop
Set SrcSheet = ActiveSheet
LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
person = SrcSheet.Cells(SrcRow, NameCol).Value
Set TrgSheet = Nothing
On Error Resume Next
Set TrgSheet = Worksheets(person)
On Error GoTo 0
If TrgSheet Is Nothing Then
Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
TrgSheet.Name = person
SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
End If
TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
Next SrcRow
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
first you read the column of names in one pass and put it in an VBA array:
Dim DATA()
with SrcSheet
DATA= .range(.cells(FirstRow, NameCol), .cells(lastRow, namecol)).value2
end with
this gives you a 2D array.
then you create a new scripiting.dictionary , wich fills on a for loop with DATA, and each time a name doesn't exist, you add it to the dictionary.
Dim Dict as new scripting.dictionary 'needs a reference in VBE to : Microsoft Scripting Runtime
dim i& 'long
dim h$ 'string
for i=1 to lastrow-firstrow+1
h=DATA(i,1)
if not dict.exists(h) then
dict(h)=i 'creaates an entry with key=h, item=whatever , here i
end if
next i
You can either create the new worksheets on the fly while adding entries to Dict, or loop later for i=1 to dict.count ...
at the end , you reset all : erase DATA : set Dict=nothing.
Note that this code does not need error handling.
Plz comment on how much time this version needs to do the same task now.
EDIT : your do while looks slow (copy select, insert). If possible B.value2=A.value2 from a range perspective.

Merge specific sheets by adding the sheet name as the first column

I have quite a number of sheets whose names end in _A or _B.
I would like to merge all sheets ending in _A or _B under one another. They have the same number of columns, but different number of rows. However, when merging, I want the sheetname to be repeated all the way down the last row of that sheet in the merged sheet. Result:
I want the results to be saved in the same workbook but in a sheet called "merged".
here is the example sheet if you would like to work on.
what I have tried:
Sub Merge_into_One()
Dim ws As Worksheet
Dim TargetRow As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
TargetRow = 1
For Each ws In ActiveWorkbook.Sheets
With ws
If .Name Like "*" & strSearch & "_A" Or _
.Name Like "*" & strSearch & "_B" Then
.Range("A1:C99").Copy
With Worksheets("Merged").Cells(TargetRow, 1)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
TargetRow = TargetRow + 99
End If
End With
Next ws
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
But here, i am taking 99 rows, supposing that my rows will not exceed this number. However, I want to take exactly the same number of rows that appear in each sheet, not more not less. And here I cannot put the name of the sheet in the first column and repeat it until the last hit of the same sheet.
Not tested. EDIT: Oops I forgot a few things it seems.
dim RowsToMerge as integer
dim RowsPresent
dim RangeToMerge as range
For i = 1 To ActiveWorkbook.Worksheets.Count
If Instr(Worksheets(i).Name, "ABC") <> 0 Then
Set ws = Worksheets(i)
RowsToMerge = ws.Cells(Rows.Count, "A").End(xlUp).Row
RowsPresent = Sheets("Merged").Cells(Rows.Count, "A").End(xlUp).Row
Set RangeToMerge = ws.Range("A1:C" & RowsToMerge)
ws.RangeToMerge.Copy destination:=Worksheets("Merged").Range("B" & RowsPresent + 1)
Worksheets("Merged").Range("A" & RowsPresent + 1) = ws.Name
End If
Next

Selecting a field in macro and cutting it out in a loop

I need to select a field of cells (table) in an Excel worksheet, cut the selection out and then paste it into a new separate sheet. There are like thousand tables below one another in this worksheet and I want to automaticly cut them out and paste them into separate sheets. The tables are separated by cells with the # symbol inside but I dont know if it is helpful in any way. When I recorded this macro for the first table it run like this:
Sub Makro1()
Range("A2:AB20").Select
Selection.Cut
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
End Sub
Now I want to make a loop which would go through the whole worksheet, dynamically select every table which would be delimited by the # sign in a col A and paste it into new sheet. I dont want to choose exact range A2:AB20, but I want to make selection according to this # sign.
Here's a screenshot
This will populate an array with the indicies of all your hash values. This should provide you with the reference point that you need to collect the appropriate data.
Sub FindHashmarksInColumnA()
Dim c As Range
Dim indices() As Long
Dim i As Long
Dim iMax As Double
Dim ws As Worksheet
Set ws = ActiveSheet
i = 0
iMax = Application.WorksheetFunction.CountIf(ws.Range("A:A"), "#")
ReDim indices(1 To iMax)
For Each c In ws.UsedRange.Columns(1).Cells
If c.Value = "#" Then
i = i + 1
indices(i) = c.Row
End If
Next c
' For each index,
' Count rows in table,
' Copy data offset from reference of hashmark,
' Paste onto new sheet in appropriate location etc.
End Sub
Try this code. You might need to adjust the top 4 constants to your need:
Sub CopyToSheets()
Const cStrSourceSheet As String = "tabulky"
Const cStrStartAddress As String = "A2"
Const cStrSheetNamePrefix As String = "Result"
Const cStrDivider As String = "#"
Dim rngSource As Range
Dim lngMaxRow As Long, lngLastDividerRow As Long, lngRowCount As Long
Dim wsTarget As Worksheet
Dim lngCounter As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Delete old worksheets
Application.DisplayAlerts = False
For Each wsTarget In Sheets
If InStr(wsTarget.Name, cStrSheetNamePrefix) Then wsTarget.Delete
Next
Application.DisplayAlerts = True
With Sheets(cStrSourceSheet)
Set rngSource = .Range(cStrStartAddress)
lngLastDividerRow = rngSource.Row
lngMaxRow = .Cells(Rows.Count, 1).End(xlUp).Row
End With
Set rngSource = rngSource.Offset(1)
While rngSource.Row < lngMaxRow
If rngSource = cStrDivider Then
lngCounter = lngCounter + 1
Set wsTarget = Sheets.Add(After:=Sheets(Sheets.Count))
wsTarget.Name = cStrSheetNamePrefix & " " & lngCounter
lngRowCount = rngSource.Row - lngLastDividerRow - 1
rngSource.Offset(-lngRowCount - 1).Resize(lngRowCount).EntireRow.Copy _
wsTarget.Range("A1").Resize(lngRowCount).EntireRow
lngLastDividerRow = rngSource.Row
End If
Set rngSource = rngSource.Offset(1)
Wend
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub