Solved: generate ws from template adding data from range on main sheet

[mperrah]

I have changed the purpose of a previous thread so I started a new one here.

I have a workbook working great for printing multiple rows of data on a form using a range and a template.
The raw data is on sheet(1) and the template is sheet(2) that gets populated and then printed based on rows with checks on sheet(1).

Now my boss asked to limit paper storage, so I need to make a new worksheet for each row of data to archive instead of printing.
I plan to update and save the file each week (starting with an empty slate weekly) so the size is not an issue (usually 45 worksheets at most)

There are three worksheets "data" "statement" and "raw". I paste the raw data to the raw page, run the "modify" macro which trims the columns and pastes the result to "data" then check the column "A" to pick files rows to print and click the print macro comand button at top.

Can a macro generate new worksheets based on the "statement" worksheet using the data and keep them in this workbook instead of printing?

Thanks for your help,
Mark

[mperrah]

I got the macro working to add a new worksheet for each checked row.
Where do I set the variable to name each new tab?
I want to use the cell "D8" the workorder number as the name.

I'm not sure where to load the variable and where to call it.
Any suggestions?

Thanks in advance.
Mark

Here is the code:
[VBA]Option Explicit
Option Base 0
Sub AddAsTabs()
Dim FormWks As Worksheet
Dim DataWks As Worksheet
Dim myRng As Range
Dim myCell As Range
Dim iCtr As Long
Dim myAddresses As Variant
Dim lOrders As Long
Dim i As Long
Dim tabLabel As String


Set FormWks = Worksheets("Statement")
Set DataWks = Worksheets("Data")

'checked boxes on the tech sheet will fill the following cells on QC Form
myAddresses = Array("A2", "B5", "D7", "F4", "B10", "D10", "D6", "D8", "F11", "B11", "B12", "F12", "B4", "D12")
'they will be fed into the cells above in the order shown
'they will be derived from each row with a check mark
'read into the array from left to right.

With DataWks
'first row of data to last row of data in column B
Set myRng = .Range("B3", .Cells(.Rows.Count, "B").End(xlUp))
End With

For Each myCell In myRng.Cells
With myCell
If IsEmpty(.Offset(0, -1)) Then
'if the row is not marked, do nothing
ElseIf myCell.Offset(0, -1).Value = "a" Then
'.Offset(0, -1).ClearContents 'clear mark for the next time
For iCtr = LBound(myAddresses) To UBound(myAddresses)
FormWks.Range(myAddresses(iCtr)).Value _
= myCell.Offset(0, iCtr).Value
Next iCtr
Application.Calculate 'just in case
'after testing, change to Preview to False to Print

With FormWks
.Select
.Copy After:=Worksheets(Worksheets.Count)
End With
'ActiveSheet.Name = tabLabel (where can I add set the value to "D8" fro each loop?

lOrders = lOrders + 1
End If
End With
Next myCell

End Sub
[/VBA]

[lucas]

Try it like this....
[VBA]Option Explicit
Option Base 0
Sub PrintUsingDatabase()
Dim FormWks As Worksheet
Dim DataWks As Worksheet
Dim myRng As Range
Dim myCell As Range
Dim iCtr As Long
Dim myAddresses As Variant
Dim lOrders As Long
Set FormWks = Worksheets("Statement")
Set DataWks = Worksheets("Data")
'checked boxes on the tech sheet will fill the following cells on the route sheet
myAddresses = Array("A2", "B5", "D7", "F4", "B10", "D10", "D6", "D8", "F11", "B11", "B12", "F12", "B4", "D12")
'they will be fed into the cells above in the order shown
'they will be derived from each row with a check mark
'read into the arrar from left to right.

With DataWks
'first row of data to last row of data in column B
Set myRng = .Range("B3", .Cells(.Rows.Count, "B").End(xlUp))
End With
For Each myCell In myRng.Cells
With myCell
If IsEmpty(.Offset(0, -1)) Then
'if the row is not marked, do nothing
ElseIf myCell.Offset(0, -1).Value = "a" Then
'.Offset(0, -1).ClearContents 'clear mark for the next time
For iCtr = LBound(myAddresses) To UBound(myAddresses)
FormWks.Range(myAddresses(iCtr)).Value _
= myCell.Offset(0, iCtr).Value
Next iCtr
Application.Calculate 'just in case
'after testing, change to Preview to False to Print
' FormWks.PrintOut 'Preview:=True
FormWks.Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Range("D8").Value
' lOrders = lOrders + 1
End If
End With
Next myCell

End Sub[/VBA]

[mperrah]

Thank you lucas,
This forum is so helpful!

To re-cap what this file can do...
I pull raw data from another file and paste the cells into the "raw" tab
then run the macro ("update" button) to remove columns I don't need
and paste the results into the"data" page
then I put a check in front of non-adjacent rows of jobs I want
click the "print" to populate a form with the raw data and print
or make a new tab with the filled out form and have a specified cell as the tab name (job phone number).

How much do you think this form would be worth as a coding job?
just curious.

Your help is priceless

Thank you again for everything.
Mark

[lucas]

Hi Mark,
Glad it worked for you. It was originally coded by Ken Puls(I think). Be sure to mark your thread solved using the thread tools at the top of the page.

[mperrah]

For sure

One last thing

If I click to add tabs and i leave a row checked that has already been inserted it makes a duplicate. Is there a way to check if a tab with the same name exists before adding a duplicate.
If so, can we be prompted for an option to rename the dup or cancel adding it?

Thank you again.
Mark

Almost all solved

[mperrah]

This version creates a msg box if a duplicate name is about to be generated and ends the sub, informing the user no files were sent.

Is there a way to have an input on the msg box
that can start with name about to be used
and give an option to edit the name?

I'll post what I have.

Thanks for your insight.

Mark

[Charlize]

Try this instead of the messagebox ...
[vba]checking_again:
For Each ws In Worksheets
If ws.Name = newSheetName Or newSheetName = "" Or IsNumeric(newSheetName) Then
Beep
newSheetName = InputBox("Duplicate(s) found no jobs sent, uncheck jobs " & _
"previously archived or give new name ...", "Give new name", ws.Name)
GoTo checking_again
End If
Next ws[/vba]Charlize

[mperrah]

Thank you Charlize,
That works great for duplicates.
One thing, if I hit cancel on the input box it trys to use sheet one name and wont cancel the copy.
What method do I use to cancel the copy if they click cancel?
Thanks again,
Mark

[Aussiebear]

G'day Mperrah, I was wondering if you could explain for my benefit your code in the modify macro please? I am confused as to what it is meant to be doing.

You wrote the following

[VBA]Sub Modify()
Sheets("raw").Select
Range("A1").Select

Rows("1:1").Select
Selection.Delete Shift:=xlUp
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Columns("B:C").Select
Selection.Delete Shift:=xlToLeft
Columns("C").Select
Selection.Delete Shift:=xlToLeft
Columns("D").Select
Selection.Delete Shift:=xlToLeft
Columns("M:O").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("M:M").Select
Selection.Delete Shift:=xlToLeft
Columns("N:P").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("N:O").Select
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Columns("O:O").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Range(Selection, Selection.End(xlToRight)).Select
Columns("O:O").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
Cells.Select
Cells.EntireColumn.AutoFit
Range("M1").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.Copy
Sheets("Data").Select
Range("C3").Select
ActiveSheet.Paste
End Sub
[/VBA]

As I read it you are trying to select columns "A" to "D" for deletion and shift the columns left, could that not be written as

[VBA]Columns ("A").Select
Selection.Delete Shift:=xlToLeft[/VBA]

Then from the line Columns ("M:O") you follow that with 8 lines of Selection.Delete Shift:=xlToLeft, then you reselect Column M for deletion, Columns N to P for deletion twice, then select columns N to O for deletion.

Then once I look past that I see Column O being selected again with 5 lines of Range.Selection. End(xlToRight) for deletion.

You then select Range("M1") for selection with 1 xlDown followed by two xlToLeft's, followed by a xlUp requests.

I am utterly confused here as to what the intention of this macro is.

[mdmackillop]

Hi Ted,
This code demonstrates the problem in deleting columns from the left (or rows from the top). The references keep changing. Delete starting from the right, and everything is much simpler eg
[vba]Sub Macro1()
Dim Arr
Arr = Array(1, 3, 5, 7, 9)
For i = 4 To 0 Step -1
Columns(Arr(i)).Delete
Next
End Sub


[/vba]

[Aussiebear]

So in Mperrah's code by deleting Columns("A:B") and shifting left, column "C" became Column "A" and the next selection was picking up what was initially Columns "D" & "E" as Columns "B" & "C"?

[mdmackillop]

Exactly. This is obviously recorded code, but would still be simplified by recording the deletions commencing from the right.

[Aussiebear]

or from the bottom, where possible?

[mperrah]

Howdy,
XLD has it. I have to generate reports that use data from a web based data base.
The raw data comes in with a ton of columns I dont need and most of what I do is take the raw data and either print or archive snippets
(based on date or other factors)
I alwayse remove the same columns and got used to doing it manualy rather quickly. My coding skills are far from what this forum has at their fingertips, so I used the macro recorder as I ran through one of my deleting frensies.

The other codes I've pulled together exclusively from the gurus here.

I'm still working on the input box for the new tab label. Canceling the box does not end the sub. any suggestions?

[Aussiebear]

Have you tried the following

[VBA]Sub Whatevername()
' your code
Unload Me
End Sub[/VBA]

[mperrah]

Where do I insert this?
I had a msg box that I changed to input after have duplicate problems.

here is part of the code I think it needs to go in

[VBA]newSheetName = FormWks.Range("D10")

For Each ws In Worksheets
If ws.Name = newSheetName Or newSheetName = "" Or IsNumeric(newSheetName) Then
MsgBox "Duplicate(s) found no jobs sent, uncheck jobs previously archived", vbInformation
Exit Sub
End If
Next

FormWks.Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = newSheetName

End If[/VBA]

[mperrah]

Sorry wrong code on previous post. This is the whole module
[VBA]Sub AddToTabs()
Dim FormWks As Worksheet
Dim DataWks As Worksheet
Dim ws As Worksheet
Dim newSheetName As String
Dim myRng As Range
Dim myCell As Range
Dim iCtr As Long
Dim myAddresses As Variant
Set FormWks = Worksheets("Statement")
Set DataWks = Worksheets("Data")
'checked boxes on the tech sheet will fill the following cells on the route sheet
myAddresses = Array("A2", "B5", "D7", "F4", "B10", "D10", "D6", "D8", "F11", "B11", "B12", "F12", "B4", "D12")
'they will be fed into the cells above in the order shown
'they will be derived from each row with a check mark
'read into the arrar from left to right.

With DataWks
'first row of data to last row of data in column B
Set myRng = .Range("B3", .Cells(.Rows.Count, "B").End(xlUp))
End With
For Each myCell In myRng.Cells
With myCell
If IsEmpty(.Offset(0, -1)) Then
'if the row is not marked, do nothing
ElseIf myCell.Offset(0, -1).Value = "a" Then
'.Offset(0, -1).ClearContents 'clear mark for the next time
For iCtr = LBound(myAddresses) To UBound(myAddresses)
FormWks.Range(myAddresses(iCtr)).Value = myCell.Offset(0, iCtr).Value
Next iCtr
Application.Calculate 'just in case

newSheetName = FormWks.Range("D10")

checking_again:
For Each ws In Worksheets
If ws.Name = newSheetName Or newSheetName = "" Or IsNumeric(newSheetName) Then
Beep
newSheetName = InputBox("Duplicate(s) found no jobs sent, uncheck jobs " & _
"previously archived or give new name ...", "Give new name", ws.Name)
GoTo checking_again

End If
Next ws

FormWks.Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = newSheetName

End If
End With
Next myCell

End Sub

[/VBA]

[Aussiebear]

Try last line before End Sub

[Aussiebear]

Sorry, initially thought you had it on a form. "End Sub" closes a sub, but it now seems that you only want it to run once, is that right?