PDA

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



mperrah
04-01-2007, 11:02 PM
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,:hi:
Mark

mperrah
04-03-2007, 02:33 PM
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:
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

lucas
04-03-2007, 03:49 PM
Try it like this....
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

mperrah
04-03-2007, 05:00 PM
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
:bow:

lucas
04-03-2007, 06:32 PM
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
04-03-2007, 07:14 PM
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
04-05-2007, 12:44 AM
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
04-05-2007, 02:28 AM
Try this instead of the messagebox ...
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 wsCharlize

mperrah
04-07-2007, 02:22 PM
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
04-07-2007, 03:32 PM
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

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:D").Select
Selection.Delete Shift:=xlToLeft
Columns("D: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


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

Columns ("A:D").Select
Selection.Delete Shift:=xlToLeft

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
04-07-2007, 03:44 PM
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
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

Aussiebear
04-07-2007, 04:49 PM
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
04-07-2007, 04:54 PM
Exactly. This is obviously recorded code, but would still be simplified by recording the deletions commencing from the right.

Aussiebear
04-07-2007, 04:56 PM
or from the bottom, where possible?

mperrah
04-07-2007, 08:26 PM
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
04-07-2007, 08:32 PM
Have you tried the following

Sub Whatevername()
' your code
Unload Me
End Sub

mperrah
04-07-2007, 11:47 PM
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

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

mperrah
04-07-2007, 11:51 PM
Sorry wrong code on previous post. This is the whole module
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

Aussiebear
04-08-2007, 01:00 AM
Try last line before End Sub

Aussiebear
04-08-2007, 01:06 AM
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?

mdmackillop
04-08-2007, 03:12 AM
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?
Cancel returns "", same as clearing the box, so something like
newsheetname = InputBox("Duplicate(s) found no jobs sent, uncheck jobs " & _
"previously archived or give new name ...", "Give new name", ws.Name)
If newsheetname = "" Then Exit For

Charlize
04-08-2007, 09:38 AM
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,
Markchecking_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)
If newSheetName = vbNullString Then
Exit Sub
End If
GoTo checking_again
End If
Next ws

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

mperrah
04-09-2007, 10:16 AM
Awsome awsome awsome.
You got it!!
Thank you so much for everyones help.
Mark

mperrah
04-09-2007, 10:24 AM
Here is a final version, working great.
It takes database info I past on sheet(3)
command button macro on sheet(1) edits the data and pastes to sheet(1)
2nd macro button on sheet(1) prints checked rows by transfering info to a templete and printing out.
3rd macro button on sheet(1) transfers each checked row of data to a form then copies that sheet to the end of the workbook and names it from a specified cell of the form (job phone number)
If a duplicate sheet is being copied you can change the name or cancel copy.

Thank you all again.

Mark
:friends:

mperrah
07-22-2007, 12:58 AM
How would it look using the array method to remove these columns?
I put the column letters and the number of columns for removel from right to left, below is the format, not sure how to impliment it...

' Sub test_delete_raw()'
' Dim Arr
' Arr = Array(1, 3, 5, 7, 9)
' For i = 4 To 0 Step -1
' Columns(Arr(i)).Delete
' Next
' End Sub

' Columns("BC:IV").Select ' 202
' Columns("AT:BA").Select ' 8
' Columns("T:AR").Select ' 25
' Columns("O:O").Select ' 1
' Columns("J:J").Select ' 1
' Columns("G:H").Select ' 2
' Columns("D:E").Select ' 2
' Columns("A:B").Select ' 2

mperrah
07-22-2007, 01:16 AM
Like this?
' Sub test_delete_raw()
' Dim Arr
' Arr = Array(1:2, 4:5, 7:8, 10, 15, 20-44, 46-53, 55-256)
For i = 256 To 0 Step -1
' Columns(Arr(i)).Delete
' Next'
End Sub
256
Columns("BC:IV").Select 202 54 55-256
Columns("AT:BA").Select 84 6 46-53
Columns("T:AR").Select 25 21 20-44
Columns("O:O").Select 1 20 15
Columns("J:J").Select 1 19 10
Columns("G:H").Select 2 17 7-8
Columns("D:E").Select 2 15 4-5
Columns("A:B").Select 2 13 1-2