Auto creation of sheets based on Data sheet with a sample output shown next to it

[paradise]

Hi,
Let me explain my problem.As enclosed in my attachment,I have 2 sheets.They are as follows :

-' Data ' Sheet
- Sample output sheet based on 'Data' Sheet

Here in 'Data' sheet I have 87 parties in column B, Address in column C,PAN in column D,sales value in column E,Debit in column in F and Credit in column G.Based on data sheet,I want to create automatically all the 87 sheets linked with column B,C,D,E,F,G,data.A sample of one party is shown after "Data" sheet.In that sample output of one party worksheet,following links exist that is connected with 'Data' sheet which are -

G3,A7,A8,A9,A13,A14,A15 .These are variable whereas all other matters are constant.

If you require further info,do let me know.

With Best Rgds,
suresh

[mancubus]

hi.

try this.

i used a template worksheet to produce company statements.

and see the attachment.





Sub create_from_template_sheet()


Dim ws As Worksheet
Dim wsName As String
Dim i As Long, LastRow As Long

Set ws = Worksheets("Data")
LastRow = ws.Range("B" & Rows.Count).End(xlUp).Row

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

For i = 5 To LastRow
Worksheets("temp").Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet
wsName = Left(ws.Range("B" & i).Value, 31)
'to ensure ws name's length is less than or equal to 31
wsName = Replace(Replace(Replace(Replace(Replace(Replace(Replace(wsName, ":", ""), "/", ""), "\", ""), "?", ""), "*", ""), "[", ""), "]", "")
'to ensure there are no invalid characters in sheet names
.Name = wsName
.Range("G3").Value = "Date: " & ws.Range("C1").Value
.Range("A7").Value = "Name of party: " & ws.Range("B" & i).Value
.Range("A8").Value = "Address: " & ws.Range("C" & i).Value
.Range("A9").Value = "PAN No: " & ws.Range("D" & i).Value
.Range("A13").Value = "This is to certify that my company has done following transaction for " & ws.Range("C2").Value & " as follows:"
.Range("A14").Value = ws.Range("E4").Value & ": Rs. " & ws.Range("E" & i).Value & "/-"
.Range("A15").Value = IIf(ws.Range("F" & i).Value > 0, "Debit Closing Balance: Rs. " & ws.Range("F" & i).Value, "Credit Closing Balance: Rs. " & ws.Range("G" & i).Value) & "/-"
End With
Next

ws.Activate


End Sub

[paradise]

Dear Sir,

Thanks for the reply.It did not do few things from your given code-

1.It did not change / refreshes the sheets when anything I changes in the main 'Data' sheet

2.Is it possible to use check Box control from A5 onwards in 'Data' sheet and filter option A4,so that when I check on A4,it automatically get checked all the data for automatically generating sheets and also when any party sheet (column B of 'Data' sheet) I did not like to generate I can manually uncheck all those check box which is below A4 i.e A5 onwards.

3.Where there is no data,instead of displaying '0' should be display '-'

Hope this might get solved too.

With Best Rgds,

suresh

[paradise]

In addition to above,
In your above code at line-
.Range("A14").Value = ws.Range("E4").Value & ": Rs. " & ws.Range("E" & i).Value & "/-"
.Range("A15").Value = IIf(ws.Range("F" & i).Value > 0, "Debit Closing Balance: Rs. " & ws.Range("F" & i).Value, "Credit Closing Balance: Rs. " & ws.Range("G" & i).Value) & "/-"

I want to interpret those value in words in brackets just after value (in A14 & A15) by using the below code.How can you merge it in your existing code.You can delete all unncessary lines that you do not require or you can shorten the below given code.
The code is as follows :


Function SpellNepalese(ByVal MyNumber)

'**** Yogi Anand -- ANAND Enterprises -- Rochester Hills MI 48309 -- 248-375-5710 www.anandent.com (http://www.anandent.com)
'**** Last updated 03-Oct-2003
'**** SpellIndian (modified on 20-Sep-2003 to 1) show Rupees to precede, and to show "" for 0 paise)
'**** ySpellRupees (on 20-Nov-2002)
'**** Excel UDF to spell Indian Currency -- Rupees and Paise into text
'**** Indian currency starts off with 1000s, and after that only with 100s
'**** 1000 (Thousand) -- 1,00,000 (Lac or Lakh) -- 1,00,00,000 (Crore) -- 1,00,00,00,000 (Arab)
'**** (this UDF is based on SpellNumber by Microsoft)
'****************' Main Function *'****************

Dim Rupees, Paise, Temp
Dim DecimalPlace, Count
ReDim Place(9) As String
Place(2) = " Thousand "
Place(3) = " Lac "
Place(4) = " Crore "
Place(5) = " Arab " ' String representation of amount
MyNumber = Trim(Str(MyNumber)) ' Position of decimal place 0 if none
DecimalPlace = InStr(MyNumber, ".")
'Convert Paise and set MyNumber to Rupee amount
If DecimalPlace > 0 Then
Paise = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If
Count = 1
Do While MyNumber <> ""
If Count = 1 Then Temp = GetHundreds(Right(MyNumber, 3))
If Count > 1 Then Temp = GetHundreds(Right(MyNumber, 2))
If Temp <> "" Then Rupees = Temp & Place(Count) & Rupees
If Count = 1 And Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
If Count > 1 And Len(MyNumber) > 2 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 2)
Else
MyNumber = ""
End If
End If
Count = Count + 1
Loop
Select Case Rupees
Case ""
Rupees = "No Rupees"
Case "One"
Rupees = "One Rupee"
Case Else
'****************************************************************
'Yogi Anand on 20-Sep-2003
'modified the following two lines to display "Rupees" to precede
' rem'd the first line and added the second line
'****************************************************************
'Rupees = Rupees & " Rupees"
Rupees = "Rupees " & Rupees

End Select
Select Case Paise
Case ""
'****************************************************************
'Yogi Anand on 20-Sep-2003
'modified the following two lines to display nothing for no paise
' rem'd the first line and added the second line
'****************************************************************

'Paise = " and No Paise"
'****************************************************************
'Yogi Anand on 03-Oct-2003
'modified the following line to display " Only" for no paise
' rem'd the first line and added the second line
'****************************************************************
'Paise = ""
Paise = " Only"
Case "One"
Paise = " and One Paisa"
Case Else
Paise = " and " & Paise & " Paise"

End Select
SpellNepalese = Rupees & Paise
End Function
'*******************************************
' Converts a number from 100-999 into text *
'*******************************************
Function GetHundreds(ByVal MyNumber)
Dim Result As String
If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3) 'Convert the hundreds place
If Mid(MyNumber, 1, 1) <> "0" Then
Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
End If
'Convert the tens and ones place
If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & GetTens(Mid(MyNumber, 2))
Else
Result = Result & GetDigit(Mid(MyNumber, 3))
End If
GetHundreds = Result
End Function
'*********************************************
' Converts a number from 10 to 99 into text. *
'*********************************************
Function GetTens(TensText)
Dim Result As String
Result = "" 'null out the temporary function value
If Val(Left(TensText, 1)) = 1 Then ' If value between 10-19
Select Case Val(TensText)
Case 10: Result = "Ten"
Case 11: Result = "Eleven"
Case 12: Result = "Twelve"
Case 13: Result = "Thirteen"
Case 14: Result = "Fourteen"
Case 15: Result = "Fifteen"
Case 16: Result = "Sixteen"
Case 17: Result = "Seventeen"
Case 18: Result = "Eighteen"
Case 19: Result = "Nineteen"
Case Else
End Select
Else ' If value between 20-99
Select Case Val(Left(TensText, 1))
Case 2: Result = "Twenty "
Case 3: Result = "Thirty "
Case 4: Result = "Forty "
Case 5: Result = "Fifty "
Case 6: Result = "Sixty "
Case 7: Result = "Seventy "
Case 8: Result = "Eighty "
Case 9: Result = "Ninety "
Case Else
End Select
Result = Result & GetDigit _
(Right(TensText, 1)) 'Retrieve ones place
End If
GetTens = Result
End Function
'*******************************************
' Converts a number from 1 to 9 into text. *
'*******************************************
Function GetDigit(Digit)
Select Case Val(Digit)
Case 1: GetDigit = "One"
Case 2: GetDigit = "Two"
Case 3: GetDigit = "Three"
Case 4: GetDigit = "Four"
Case 5: GetDigit = "Five"
Case 6: GetDigit = "Six"
Case 7: GetDigit = "Seven"
Case 8: GetDigit = "Eight"
Case 9: GetDigit = "Nine"
Case Else: GetDigit = ""
End Select
End Function

[mancubus]

you are welcome. ----- i amended the code as per your request. but if i were you, i would finish all the work before producing the statements and not use the formulas to return values. ------ one of my colleauges has requested a similar project. so i spent some time on your project as it will serve to my own business. ------ PS: i can't paste the code here correctly at the moment. becuase the IE in my offce computer does not print special characters such as "line feeds" in VBAX threads. and i cant upload files similarly. i will attach a file when im home.
...formula version:

Sub Create_From_Template_Sheet_CheckBoxes()
Dim ws As Worksheet
Dim wsName As String
Dim i As Long,
LastRow As Long, cbCount As Long
Set ws = Worksheets("Data")
LastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
cbCount = 0
For i = 5 To LastRow
If ws.CheckBoxes(i - 4).Value = xlOn Then
'start from first checkbox whose index number is 1. first i in the loop is 5 then i-4 is 1.
cbCount = cbCount + 1
Worksheets("temp").Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet
wsName = Left(ws.Range("B" & i).Value, 31)
'to ensure ws name's length is less than or equal to 31
wsName = Replace(Replace(Replace(Replace(Replace(Replace(Replace(wsName, ":", ""), "/", ""), "\", ""), "?", ""), "*", ""), "[", ""), "]", "")
'to ensure there are no invalid characters in sheet names
.Name = wsName
.Range("G3").Formula = "=""Date : ""&Data!C1"
.Range("A7").Formula = "=""Name of party : "" &Data!B" & i
.Range("A8").Formula = "=""Address : ""&Data!C" & i
.Range("A9").Formula = "=""PAN No : ""&Data!D" & i
.Range("A13").Formula = "=""This is to certify that my company has done following transaction for ""&Data!C2&"" as follows :"""
.Range("A14").Formula = "=Data!E4&" & """ : Rs. """ & "&" & "Data!E" & i & "&" & """/-[""" & "&" & "SpellNepalese(Data!E" & i & ")" & "&" & """]""" If ws.Range("F" & i).Value > 0 Then .Range("A15").Formula = "=Data!F4&" & """ Closing Balance : Rs. """ & "&" & "Data!F" & i & "&" & """/-[""" & "&" & "SpellNepalese(Data!F" & i & ")" & "&" & """]"""
ElseIf ws.Range("G" & i).Value > 0 Then
.Range("A15").Formula = "=Data!G4&" & """ Closing Balance : Rs. """ & "&" & "Data!G" & i & "&" & """/-[""" & "&" & "SpellNepalese(Data!F" & i & ")" & "&" & """]"""
Else
.Range("A15").Formula = "'-"
End If
End With
End If
Next
If cbCount = 0 Then
MsgBox "You did not select any companies from Data Sheet. Check at least 1 CheckBox next to company name!", vbOKOnly, "SELECT A COMPANY"
ws.Activate
Else
Worksheets("master").Activate
End If
End Sub

add check boxes:

Sub Add_CheckBoxes()
Dim ws As Worksheet
Dim i As Long,
LastRow As Long
Dim cbLeft As Double, cbTop As Double, cbHeight As Double, cbWidth As Double
Dim cb As CheckBox
Set ws = Worksheets("Data")
With ws
.CheckBoxes.Delete
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 5 To LastRow
If Not IsEmpty(.Cells(i, "B")) Then
cbTop = .Cells(i, "A").Top
cbLeft = .Cells(i, "A").Left
cbHeight = .Cells(i, "A").Height
cbWidth = .Cells(i, "A").Width
Set cb = .CheckBoxes.Add(cbLeft, cbTop, cbWidth, cbHeight)
With cb
.Caption = ""
.Value = xlOff
.Display3DShading = False
End With
End If
Next
End With
End Sub

[paradise]

Dear Sir,

Thanks for your reply.I will certainly and eagerly be waiting for your reply.

With Best Rgds,
Suresh

[mancubus]

hi.
as promised.



Sub Create_From_Template_Sheet_CheckBoxes()
'http://www.vbaexpress.com/forum/showthread.php?48272-Auto-creation-of-sheets-based-on-Data-sheet-with-a-sample-output-shown-next-to-it

Dim ws As Worksheet
Dim wsName As String
Dim i As Long, LastRow As Long, cbCount As Long

Set ws = Worksheets("Data")
LastRow = ws.Range("B" & Rows.Count).End(xlUp).Row

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

cbCount = 0
For i = 5 To LastRow
If ws.CheckBoxes(i - 4).Value = xlOn Then
'start from first checkbox whose index number is 1. since first i in the loop is 5 "i-4" is used to reach 1.
cbCount = cbCount + 1
Worksheets("temp").Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet
wsName = Left(ws.Range("B" & i).Value, 31)
'to ensure ws name's length is less than or equal to 31
wsName = Replace(Replace(Replace(Replace(Replace(Replace(Replace(wsName, ":", ""), "/", ""), "\", ""), "?", ""), "*", ""), "[", ""), "]", "")
'to ensure there are no invalid characters in sheet names
.Name = wsName
.Range("G3").Formula = "=""Date : ""&Data!C1"
.Range("A7").Formula = "=""Name of party : "" &Data!B" & i
.Range("A8").Formula = "=""Address : ""&Data!C" & i
.Range("A9").Formula = "=""PAN No : ""&Data!D" & i
.Range("A13").Formula = "=""This is to certify that my company has done following transaction for ""&Data!C2&"" as follows :"""
.Range("A14").Formula = "=Data!E4&" & """ : Rs. """ & "&" & "Data!E" & i & "&" & """/-[""" & "&" & "SpellNepalese(Data!E" & i & ")" & "&" & """]"""
If ws.Range("F" & i).Value > 0 Then
.Range("A15").Formula = "=Data!F4&" & """ Closing Balance : Rs. """ & "&" & "Data!F" & i & "&" & """/-[""" & "&" & "SpellNepalese(Data!F" & i & ")" & "&" & """]"""
ElseIf ws.Range("G" & i).Value > 0 Then
.Range("A15").Formula = "=Data!G4&" & """ Closing Balance : Rs. """ & "&" & "Data!G" & i & "&" & """/-[""" & "&" & "SpellNepalese(Data!F" & i & ")" & "&" & """]"""
Else
.Range("A15").Formula = "'-"
End If
End With
End If
Next
If cbCount = 0 Then
MsgBox "You did not select any companies from Data Sheet. Check at least 1 CheckBox next to company name!", vbOKOnly, "SELECT A COMPANY"
ws.Activate
Else
Worksheets("master").Activate
End If


End Sub









Sub Add_CheckBoxes()

Dim ws As Worksheet

Dim i As Long, LastRow As Long
Dim cbLeft As Double, cbTop As Double, cbHeight As Double, cbWidth As Double
Dim cb As CheckBox

Set ws = Worksheets("Data")
With ws
.CheckBoxes.Delete
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 5 To LastRow
If Not IsEmpty(.Cells(i, "B")) Then
cbTop = .Cells(i, "A").Top
cbLeft = .Cells(i, "A").Left
cbHeight = .Cells(i, "A").Height
cbWidth = .Cells(i, "A").Width
Set cb = .CheckBoxes.Add(cbLeft, cbTop, cbWidth, cbHeight)
With cb
.Caption = ""
.Value = xlOff
.Display3DShading = False
End With
End If
Next
End With
End Sub

[paradise]

Dear Sir,

Heaps of thanks to you.Everything worked,except one thing i.e,it did not displayed in words the amount when there is credit closing balance-

Refer SN.3

Name of party : Aakash Foods Products,Khanar Credit Closing Balance : Rs. 19800/-[No Rupees Only].....................................currency was not displayed in words but should have been mentioned 'Nineteen thousand Eight hundred' instead of 'No Rupees Only'

Refer SN.1

Name of party : A One Propacks Debit Closing Balance : Rs. 29383.5/-[Rupees Twenty Nine Thousand Three Hundred Eighty Three and Fifty Paise]...........................currency was perfectly displayed in words

Hope you can modified the existing formula.

Last but not least,I would like you to ask one more things is that this is a sample workbook and a certain number of party that I have stated in 'Data' Sheet which is around 87 parties.In real,I have more than this i.e >87 .Here, where should I modify the formula or your vba code when my numbers of party increases.

With Best Rgds,

Suresh

[mancubus]

Its a typo. Just change the F to G in the line which starts with .Range("A15").Formula

Spellnepalese part.


Can you see any part in the code "run for 87 times only". :)

The For Next loop starts at row 5 and goes down to last non blank cell in column B. The LastRow variable is assigned the row number of very last cell with data in col B.




Sub Create_From_Template_Sheet_CheckBoxes()
'http://www.vbaexpress.com/forum/showthread.php?48272-Auto-creation-of-sheets-based-on-Data-sheet-with-a-sample-output-shown-next-to-it

Dim ws As Worksheet
Dim wsName As String
Dim i As Long, LastRow As Long, cbCount As Long

Set ws = Worksheets("Data")
LastRow = ws.Range("B" & Rows.Count).End(xlUp).Row

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

cbCount = 0
For i = 5 To LastRow
If ws.CheckBoxes(i - 4).Value = xlOn Then
'start from first checkbox whose index number is 1. since first i in the loop is 5 "i-4" is used to reach 1.
cbCount = cbCount + 1
Worksheets("temp").Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet
wsName = Left(ws.Range("B" & i).Value, 31)
'to ensure ws name's length is less than or equal to 31
wsName = Replace(Replace(Replace(Replace(Replace(Replace(Replace(wsName, ":", ""), "/", ""), "\", ""), "?", ""), "*", ""), "[", ""), "]", "")
'to ensure there are no invalid characters in sheet names
.Name = wsName
.Range("G3").Formula = "=""Date : ""&Data!C1"
.Range("A7").Formula = "=""Name of party : "" &Data!B" & i
.Range("A8").Formula = "=""Address : ""&Data!C" & i
.Range("A9").Formula = "=""PAN No : ""&Data!D" & i
.Range("A13").Formula = "=""This is to certify that my company has done following transaction for ""&Data!C2&"" as follows :"""
.Range("A14").Formula = "=Data!E4&" & """ : Rs. """ & "&" & "Data!E" & i & "&" & """/-[""" & "&" & "SpellNepalese(Data!E" & i & ")" & "&" & """]"""
If ws.Range("F" & i).Value > 0 Then
.Range("A15").Formula = "=Data!F4&" & """ Closing Balance : Rs. """ & "&" & "Data!F" & i & "&" & """/-[""" & "&" & "SpellNepalese(Data!F" & i & ")" & "&" & """]"""
ElseIf ws.Range("G" & i).Value > 0 Then
.Range("A15").Formula = "=Data!G4&" & """ Closing Balance : Rs. """ & "&" & "Data!G" & i & "&" & """/-[""" & "&" & "SpellNepalese(Data!G" & i & ")" & "&" & """]"""
Else
.Range("A15").Formula = "'-"
End If
End With
End If
Next
If cbCount = 0 Then
MsgBox "You did not select any companies from Data Sheet. Check at least 1 CheckBox next to company name!", vbOKOnly, "SELECT A COMPANY"
ws.Activate
Else
Worksheets("master").Activate
End If


End Sub

[paradise]

Dear Sir,

Thanks for your prompt reply.I have pasted the code as you said,it did work for Credit balance for displaying amount in words.But while clicking command button 2 (for creating statement of all parties) it has now shown error stating compile error,sub or function not defined.

Kindly do the needful.I have enclosed a workbook,pls rectify if any error exist and revert it.After this my works would be completed.

With Best Rgds,
Suresh

[mancubus]

welcome. it appears you have deleted or not copied after amendment the macro Create_From_Template_Sheet in module Mod1_main. copy the code from workbook in post #7. and dont forget to change letter F to G in the ElseIf statement. also changing .Range("A15").Formula = "'-" to .Range("A15").Formula = "Closing Balance : -" in the Else statement will be better. i dont duplicate the problems. both codes work for me.

[paradise]

Dear Sir,

I have downloaded the workbook of post #7.And then in mod1_main, I have replaced the vba code by your code of post #9 in the first part,but still it did not worked for all party statement.Perhaps,I could not be able to figure out.

Kindly send me the revised and final workbook in attachment.

I would be eagerly waiting for your reply.

With Best Rgds,
Suresh

[mancubus]

download the file again. donot copy-paste anything.

open VBE window by hitting Alt+F11 key combination. double click Mod1_main.

the first macro is Sub Create_From_Template_Sheet_CheckBoxes(). scroll down to the line starting with .Range("A15").Formula = "=Data!G4.... change SpellNepalese(Data!F to SpellNepalese(Data!G in this line (letter F to letter G only). change .Range("A15").Formula = "'-" to .Range("A15").Formula = "Closing Balance : -" below Else statement line. donot clear the quotation marks.

scroll down to the second macro which is Sub Create_From_Template_Sheet(). scroll down to the line starting with .Range("A15").Formula = "=Data!G4.... change SpellNepalese(Data!F to SpellNepalese(Data!G in this line (letter F to letter G only). change .Range("A15").Formula = "'-" to .Range("A15").Formula = "Closing Balance : -" below Else statement line. donot clear the quotation marks.

then you will have the same file that you want me to post.



edit: attachment

[paradise]

Dear Sir,

Thanks for the reply.

As expected, I got the result.Heaps of thanks to you again.Now my problem has been solved.

With Best Rgds,
Suresh

[mancubus]

you are welcome. thanks for the feedback.