PDA

View Full Version : From Sheet.add to Workbook add method



JackMouct
12-16-2016, 09:27 AM
Hi Everyone, i am having a little issue with my coding; as it is not working. Below is what is currently working fine which is adding new sheets into active workbook. However, i would like same process for new workbook.add method. i have tried several method but not working.

In onather words. Is possible to create new workbook for each summary cell match? What i mean by that is on Activeworkbook Sheet2(Summary) from column A2 they are items in there that i want match them to Sheet1(Third Reports) column D2 and then copy the entire row and paste it into workbook for each item match. For instance in Summary tab there is item call "PCS UNI" and find this item match in Third Reports; once find it then copy entire row and paste it into new workbook. Please any helps will be grateful

I hope this makes sense

Thank you




Dim Master_Sht As Worksheet, Summary_Sht As Worksheet, New_Sht As Worksheet, Third_Sht As Worksheet
Dim rCell_Summary As Range, rCell_ThirdReports As Range
Dim Summary_Last_Row As Long, New_Sht_Next_Row As Long
Dim Total1 As Double

Application.ScreenUpdating = False

Set Master_Sht = Sheets("Third Reports")
Set Summary_Sht = Sheets("Summary")
Set Third_Sht = Sheets("Third Reports")
Summary_Last_Row = Summary_Sht.Cells(Rows.Count, "A").End(xlUp).Row

For Each rCell_Summary In Summary_Sht.Range("A2:A" & Summary_Last_Row)
Set New_Sht = Sheets.Add(After:=Sheets(Sheets.Count))


With New_Sht
.Name = rCell_Summary.Value
.Range("A1").Value = "Pers.No."
.Range("B1").Value = "Last name First name"
.Range("C1").Value = "Name of employee or applicant"
.Range("D1").Value = "ID number"
.Range("E1").Value = "Wage Type Long Text"
.Range("F1").Value = "Amount"
.Range("F1").Value = "Crcy"

End With


For Each rCell_ThirdReports In Third_Sht.Range("E2:E100000")
If rCell_ThirdReports.Value = rCell_Summary.Value Then
New_Sht_Next_Row = Application.WorksheetFunction.CountA(New_Sht.Range("A:A")) + 1

With New_Sht
.Cells(New_Sht_Next_Row, 1).Value = Third_Sht.Cells(rCell_ThirdReports.Row, 1).Value
.Cells(New_Sht_Next_Row, 2).Value = Third_Sht.Cells(rCell_ThirdReports.Row, 2).Value
.Cells(New_Sht_Next_Row, 3).Value = Third_Sht.Cells(rCell_ThirdReports.Row, 3).Value
.Cells(New_Sht_Next_Row, 4).Value = Third_Sht.Cells(rCell_ThirdReports.Row, 4).Value
.Cells(New_Sht_Next_Row, 5).Value = Third_Sht.Cells(rCell_ThirdReports.Row, 5).Value
.Cells(New_Sht_Next_Row, 6).Value = Third_Sht.Cells(rCell_ThirdReports.Row, 6).Value
End With
End If
Next rCell_ThirdReports

p45cal
12-16-2016, 07:31 PM
try either:
For Each rCell_Summary In Summary_Sht.Range("A2:A" & Summary_Last_Row)
' Set New_Sht = Sheets.Add(After:=Sheets(Sheets.Count))
OrigSheetsInNewWorkbook = Application.SheetsInNewWorkbook 'conserve current value for later
Application.SheetsInNewWorkbook = 1 'only one worksheet in new workbook - if you're creating lots of new workbooks, this line and the one above would probably be better earlier in the Sub, before all the looping.
Set New_Wkbk=Workbooks.add
Set New_Sht = New_Wkbk.Sheets(1)
Application.SheetsInNewWorkbook = OrigSheetsInNewWorkbook 'restore to original - if you're creating lots of new workbooks this line would probably be better lower down after all the looping
With New_Sht
.Name = rCell_Summary.Value
.Range("A1").Value = "Pers.No."
.Range("B1").Value = "Last name First name"
.Range("C1").Value = "Name of employee or applicant"
.Range("D1").Value = "ID number"
.Range("E1").Value = "Wage Type Long Text"
.Range("F1").Value = "Amount"
.Range("F1").Value = "Crcy" 'shouldn't this be G1?
End With
For Each rCell_ThirdReports In Third_Sht.Range("E2:E100000")
If rCell_ThirdReports.Value = rCell_Summary.Value Then
New_Sht_Next_Row = Application.WorksheetFunction.CountA(New_Sht.Range("A:A")) + 1
New_Sht.Cells(New_Sht_Next_Row, 1).Resize(, 6).Value = Third_Sht.Cells(rCell_ThirdReports.Row, 1).Resize(, 6).Value 'a bit quicker
End If
Next rCell_ThirdReports
or:
For Each rCell_Summary In Summary_Sht.Range("A2:A" & Summary_Last_Row)
Set New_Sht = Sheets.Add(After:=Sheets(Sheets.Count))
With New_Sht
.Name = rCell_Summary.Value
.Range("A1").Value = "Pers.No."
.Range("B1").Value = "Last name First name"
.Range("C1").Value = "Name of employee or applicant"
.Range("D1").Value = "ID number"
.Range("E1").Value = "Wage Type Long Text"
.Range("F1").Value = "Amount"
.Range("F1").Value = "Crcy" 'shouldn't this be G1?
End With

For Each rCell_ThirdReports In Third_Sht.Range("E2:E100000")
If rCell_ThirdReports.Value = rCell_Summary.Value Then
New_Sht_Next_Row = Application.WorksheetFunction.CountA(New_Sht.Range("A:A")) + 1
New_Sht.Cells(New_Sht_Next_Row, 1).Resize(, 6).Value = Third_Sht.Cells(rCell_ThirdReports.Row, 1).Resize(, 6).Value 'a bit quicker
End If
Next rCell_ThirdReports
New_Sht.Copy 'this creates new Workbook.
Set New_Wkbk=Activeworkbook' not so robust as above snippet.
(untested)

JackMouct
12-19-2016, 07:24 AM
Hello!

Thank you so much and both method are working and much appreciated.

You are a :stars:

JackMouct
12-19-2016, 10:12 AM
Hello again!

Once again thank you for your with my first steps. Could you please help me again how to save as the new workbook with the name find through looping? What i mean by that; for example throughout the looping the new workbook (Sheet 1) created call "GM BA" and want save the workbook as GM BA with current month ( December 2016). Also how do i add email to it, so that relevant person receive the workbook automatically? Any help will do. thank you

p45cal
12-19-2016, 10:59 AM
I'm guessing:
New_Wkbk.SaveAs rCell_Summary.Value & " " & Format(Date, "mmmm yyyy")

As far as emailing is concerned, that's a bigger question; I suggest a new thread if after you've done some searching you can't do it.

JackMouct
12-19-2016, 04:29 PM
Will do and thank you very much for all your helps

JackMouct
12-22-2016, 05:08 AM
Hi, Thank you for your help and now i have issue to password protect the save workbook when someone try to open it. Please see below full code and may be i have messed up the whole coding and if you don't mind tidy up please.

Dim Master_Sht As Worksheet, Summary_Sht As Worksheet, New_Sht As Worksheet, Third_Sht As WorksheetDim rCell_Summary As Range, rCell_ThirdReports As Range
Dim Summary_Last_Row As Long, New_Sht_Next_Row As Long
Dim Total1 As Double
Dim New_Wkbk As Workbook, thisWb As Workbook
Dim fileName As String, Password As String


Application.ScreenUpdating = False

Set Master_Sht = Sheets("Third Reports")
Set Summary_Sht = Sheets("Summary")
Set Third_Sht = Sheets("Third Reports")
Summary_Last_Row = Summary_Sht.Cells(Rows.Count, "A").End(xlUp).Row

For Each rCell_Summary In Summary_Sht.Range("A2:A" & Summary_Last_Row)
Set New_Wkbk = Workbooks.Add
Set New_Sht = New_Wkbk.Sheets(1)


With New_Sht
.Name = rCell_Summary.Value
.Range("A1").Value = "Pers.No."
.Range("B1").Value = "Last name First name"
.Range("C1").Value = "Name of employee or applicant"
.Range("D1").Value = "ID number"
.Range("E1").Value = "Wage Type Long Text"
.Range("F1").Value = "Amount"
.Range("G1").Value = "Crcy"

End With

For Each rCell_ThirdReports In Third_Sht.Range("E2:E100000")
If rCell_ThirdReports.Value = rCell_Summary.Value Then
New_Sht_Next_Row = Application.WorksheetFunction.CountA(New_Sht.Range("A:A")) + 1
New_Sht.Cells(New_Sht_Next_Row, 1).Resize(, 6).Value = Third_Sht.Cells(rCell_ThirdReports.Row, 1).Resize(, 6).Value 'a bit quicker
End If
Next rCell_ThirdReports

Set New_Wkbk = ActiveWorkbook


With New_Sht

Total1 = Application.WorksheetFunction.Sum(.Range("F:F"))

.Cells(New_Sht_Next_Row + 2, 6).Value = Total1
.Rows(1).Font.Bold = True
.UsedRange.Columns.AutoFit

End With

With New_Wkbk

New_Wkbk.SaveAs rCell_Summary.Value & " " & Format(Date, "mmmm yyyy")


Application.DisplayAlerts = False

Set thisWb = ActiveWorkbook

With thisWb

.SaveAs fileName:=thisWb.Path, Password:="SSC"

.Close savechanges:=False
.Password = "SSC"




End With




Application.DisplayAlerts = True


'New_Wkbk.SaveAs fileName:="G:\Central Services\Retails Sales\Controls\Control Reports\Third Party\December 2016, & "".xls"", FileFormat:=xlNormal, Password:=""SSC"", WriteResPassword:="", ReadOnlyRecommended:=False,CreateBackup:=False"

End With


Next rCell_Summary


Set Master_Sht = Nothing
Set Summary_Sht = Nothing
Set Third_Sht = Nothing
Set New_Sht = Nothing


Application.CutCopyMode = False


Application.ScreenUpdating = True






End Sub

p45cal
12-22-2016, 05:28 AM
a guess:

Dim Master_Sht As Worksheet, Summary_Sht As Worksheet, New_Sht As Worksheet, Third_Sht As Worksheet
Dim rCell_Summary As Range, rCell_ThirdReports As Range
Dim Summary_Last_Row As Long, New_Sht_Next_Row As Long
Dim Total1 As Double
Dim New_Wkbk As Workbook, thisWb As Workbook
Dim fileName As String, Password As String
Application.ScreenUpdating = False
Set Master_Sht = Sheets("Third Reports")
Set Summary_Sht = Sheets("Summary")
Set Third_Sht = Sheets("Third Reports")
Summary_Last_Row = Summary_Sht.Cells(Rows.Count, "A").End(xlUp).Row
For Each rCell_Summary In Summary_Sht.Range("A2:A" & Summary_Last_Row)
Set New_Wkbk = Workbooks.Add
Set New_Sht = New_Wkbk.Sheets(1)
With New_Sht
.Name = rCell_Summary.Value
.Range("A1").Value = "Pers.No."
.Range("B1").Value = "Last name First name"
.Range("C1").Value = "Name of employee or applicant"
.Range("D1").Value = "ID number"
.Range("E1").Value = "Wage Type Long Text"
.Range("F1").Value = "Amount"
.Range("G1").Value = "Crcy"
End With
For Each rCell_ThirdReports In Third_Sht.Range("E2:E100000")
If rCell_ThirdReports.Value = rCell_Summary.Value Then
New_Sht_Next_Row = Application.WorksheetFunction.CountA(New_Sht.Range("A:A")) + 1
New_Sht.Cells(New_Sht_Next_Row, 1).Resize(, 6).Value = Third_Sht.Cells(rCell_ThirdReports.Row, 1).Resize(, 6).Value 'a bit quicker
End If
Next rCell_ThirdReports
Set New_Wkbk = ActiveWorkbook
With New_Sht
Total1 = Application.WorksheetFunction.Sum(.Range("F:F"))
.Cells(New_Sht_Next_Row + 2, 6).Value = Total1
.Rows(1).Font.Bold = True
.UsedRange.Columns.AutoFit
End With
With New_Wkbk
.SaveAs rCell_Summary.Value & " " & Format(Date, "mmmm yyyy"), Password:="SSC"
Application.DisplayAlerts = False
.Close savechanges:=False
Application.DisplayAlerts = True
End With
'New_Wkbk.SaveAs fileName:="G:\Central Services\Retails Sales\Controls\Control Reports\Third Party\December 2016, & "".xls"", FileFormat:=xlNormal, Password:=""SSC"", WriteResPassword:="", ReadOnlyRecommended:=False,CreateBackup:=False"
End With
Next rCell_Summary
Set Master_Sht = Nothing
Set Summary_Sht = Nothing
Set Third_Sht = Nothing
Set New_Sht = Nothing
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub