Please help me from this file i want to create a separate files of branch with all sheets and i want to sent that to separate in mail on defined list mail id.
i want to create a separate files of branch with all sheet
-
niteshvkjain -
April 26, 2020 at 1:12 PM -
Thread is marked as Resolved.
-
-
-
Do want to send a new workbook with 3 sheets of data?
Where's the email list?
-
yes different workbook for each branch. And list of email attached.
-
I can get you all the workbooks into a temp folder.
Hopefully somebody can see what is wrong with my email part,
as soon as the code runs through the email part, vNum becomes empty and just goes to end sub
You are one step closer though.
Code
Display MoreSub UsingColection() Dim wb As Workbook, bk As Workbook Dim cUnique As Collection Dim rng As Range Dim c As Range Dim sh As Worksheet Dim vNum As Variant Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet Dim svFile As String Dim oApp As Object Dim oMail As Object Set wb = ThisWorkbook With wb Set sh1 = .Sheets("Branch") Set sh2 = .Sheets("ASM") Set sh3 = .Sheets("DBR") End With With sh1 Set rng = .Range("A3:A" & .Cells(.Rows.Count, "A").End(xlUp).Row) Set cUnique = New Collection On Error Resume Next For Each c In rng.Cells cUnique.Add c.Value, CStr(c.Value) Next c On Error GoTo 0 For Each vNum In cUnique If vNum <> "Region Total" Then Set bk = Workbooks.Add With bk .Sheets.Add Count:=2 Sheets(1).Name = "Branch" Sheets(2).Name = "ASM" Sheets(3).Name = "DBR" End With .Range("A3").AutoFilter field:=1, Criteria1:=vNum sh2.Range("A2").AutoFilter field:=1, Criteria1:=vNum sh3.Range("A3").AutoFilter field:=1, Criteria1:=vNum End If With bk sh1.UsedRange.SpecialCells(xlCellTypeVisible).Copy .Sheets(1).Range("A1") sh2.UsedRange.SpecialCells(xlCellTypeVisible).Copy .Sheets(2).Range("A1") sh3.UsedRange.SpecialCells(xlCellTypeVisible).Copy .Sheets(3).Range("A1") Application.DisplayAlerts = 0 svFile = Environ("Temp") & "\" & vNum & ".xlsx" .SaveAs (svFile) .Close End With fname = svFile ' Set oMail = CreateObject("Outlook.Application").CreateItem(0) ' With oMail ' .To = "[email protected]" ' .Subject = "This is " & vNum ' .Attachments.Add fname ' .Display ' End With Next vNum Set oMail = Nothing End With End Sub
-
Thanks Alot It is working only mail is not work and one more thing can we automate sheet change like if in any file i have sheet more than this 3 than how can automate to change the sheet with loop.
-
-
Do want to send a new workbook with 3 sheets of data?
Where's the email list?
yes different workbook for each branch. And list of email attached. and want to automate sheet change through loop not with name till last sheet.
-
It would be best to have the email list in the master workbook.
I would suggest the code needs to create a temporary workbook and email that.then delete it.
Repeated for each branch
-
This will create the workbooks with variable number of worksheets.
Keep the "Rough.xlsm" workbook in a separate folder, then when running the code it will place the new workbooks in that folder.
Code
Display MoreSub CreatWorkbooks() Dim wb As Workbook, bk As Workbook Dim cUnique As Collection Dim rng As Range Dim c As Range Dim sh As Worksheet Dim vNum As Variant Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet Dim svFile As String Set wb = ThisWorkbook Set sh1 = wb.Sheets("Branch") With sh1 Set rng = .Range("A3:A" & .Cells(.Rows.Count, "A").End(xlUp).Row) Set cUnique = New Collection On Error Resume Next For Each c In rng.Cells cUnique.Add c.Value, CStr(c.Value) Next c On Error GoTo 0 For Each vNum In cUnique If vNum <> "Region Total" Then For Each sh In wb.Sheets With sh .Range("A2").AutoFilter field:=1, Criteria1:=vNum End With Next sh '-------------Add workbook and sheets---------------- Set bk = Workbooks.Add With wb For Each sh In .Sheets With bk If sh.Visible Then .Sheets.Add after:=.Sheets(.Sheets.Count) ActiveSheet.Name = sh.Name End If End With Next sh End With Application.DisplayAlerts = False bk.Sheets(1).Delete '------------------------------------------------- For Each sh In wb.Sheets If sh.Visible = True Then wb.Sheets(sh.Name).UsedRange.SpecialCells(xlCellTypeVisible).Copy _ bk.Sheets(sh.Name).Range("A1") End If Next sh svFile = wb.Path & "\" & vNum & ".xlsx" bk.SaveAs (svFile) bk.Close End If Next vNum .AutoFilterMode = False End With End Sub
Participate now!
Don’t have an account yet? Register yourself now and be a part of our community!