suhas_shah
New Member
- Joined
- Sep 23, 2006
- Messages
- 39
Hi,
I have given below the macro which goes thru a excel file filters out data and creates a excel worksheet with multiple pivot table report.
using : MS Excel 2007, Microsoft Outlook 2007 & saving the report in Excel 2003 format.
Considering data of aroung 5000 lines it takes 8 to 10 seconds for each person
I would like to speed up the thing as sending to more thatn 300 persons on daily basis
Thanks in advance
Suhas
Sub Send_mail()
Dim OutApp As Object
Dim OutMail As Object
' Dim PT As PivotTable
' Dim PI As PivotItem
Dim lr As Integer
Dim stlr As Integer
Dim mlr As Integer
Dim rng As Range
Dim mrng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim Dtfilt As Date
Dim FilterRange As Range
Dim FieldNum As Integer
Dim formonth As String
Dim Source As Range
Dim Dest As Workbook
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim Tempwind As String
Dim mcont As String
Dim mfull As String
Dim TempWB As Workbook
Dim Tempfilepath As String
Dim Tempfilename As String
Dim FileExtstr As String
Dim Fileformatnum As Long
Dim Wb As Workbook
Dim Subj As String
Dim Lrow As Integer
Dim Tosnd As String
Dim Tosndstkall As String
Dim Toprn As String
Dim Toprnmr As String
Dim ToDel As String
Dim Toprnabm As String
Dim Toprnrbm As String
Dim Toprnzsm As String
Dim Tosndmr As String
Dim Tosndabm As String
Dim Tosndrbm As String
Dim Tosndzsm As String
Dim Tosndstk As String
Dim Toprnsht As String
Dim Towaitprn As String
Dim Towaitsnd As String
Dim Prnname As String
Dim divnm As String
Dim stocknm As String
Dim Sumamt As Integer
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = False
.Calculation = xlCalculationAutomatic
End With
Sheets("Data").Select
If Worksheets("Data").FilterMode = True Then
Selection.AutoFilter
End If
smsgbody = "Dear sir/madam," & vbCr & vbCr
smsgbody = smsgbody & "Please find enclosed herewith Excel file containing details of" & vbCr
smsgbody = smsgbody & "a. HQ-Flash" & vbCr
smsgbody = smsgbody & "b. HQ-Qty. Details" & vbCr
smsgbody = smsgbody & "c. HQ-wise Pending" & vbCr
smsgbody = smsgbody & "d. Pending Product" & vbCr
smsgbody = smsgbody & "e. DATA-Details" & vbCr
smsgbody = smsgbody & "" & vbCr
smsgbody = smsgbody & "The same is for your information." & vbCr
smsgbody = smsgbody & "" & vbCr
smsgbody = smsgbody & "CFA : H M Sales Corporation" & vbCr
smsgbody = smsgbody & "Godown No. 1,2, Behind Filtrum India" & vbCr
smsgbody = smsgbody & "Opp. Tata Johnson Controls" & vbCr
smsgbody = smsgbody & "Between Phase I & II, Taluka : Mulshi" & vbCr
smsgbody = smsgbody & "Hinjewadi : Pune : 411 057" & vbCr
smsgbody = smsgbody & "" & vbCr
smsgbody = smsgbody & "Phone : (020) 39821274 / 76 / 77 / 75" & vbCr
smsgbody = smsgbody & "" & vbCr
smsgbody = smsgbody & "Fax : (020) 39821265 / 83" & vbCr
smsgbody = smsgbody & "" & vbCr
smsgbody = smsgbody & "Thanks & Regards" & vbCr
smsgbody = smsgbody & "Pune C & F" & vbCr
smstgbody = "Dear sir/madam," & vbCr & vbCr
smstgbody = smstgbody & "Please find enclosed herewith Excel file containing transaction details." & vbCr
smstgbody = smstgbody & "" & vbCr
smstgbody = smstgbody & "The same is for your information." & vbCr
smstgbody = smstgbody & "" & vbCr
smstgbody = smstgbody & "CFA : H M Sales Corporation" & vbCr
smstgbody = smstgbody & "Godown No. 1,2, Behind Filtrum India" & vbCr
smstgbody = smstgbody & "Opp. Tata Johnson Controls" & vbCr
smstgbody = smstgbody & "Between Phase I & II, Taluka : Mulshi" & vbCr
smstgbody = smstgbody & "Hinjewadi : Pune : 411 057" & vbCr
smstgbody = smstgbody & "" & vbCr
smstgbody = smstgbody & "Phone : (020) 39821274 / 76 / 77 / 75" & vbCr
smstgbody = smstgbody & "" & vbCr
smstgbody = smstgbody & "Fax : (020) 39821265 / 83" & vbCr
smstgbody = smstgbody & "" & vbCr
smstgbody = smstgbody & "Thanks & Regards" & vbCr
smstgbody = smstgbody & "Pune C & F" & vbCr
Dim strMyMsgResp As Integer
ToDel = "Yes"
tosndho = "No"
strMyMsgResp = 6
strMyMsgResp = MsgBox("SEND PENDING PRODUCT Report to HO " & vbLf & _
"?", vbYesNo + vbDefaultButton2)
If strMyMsgResp = 6 Then
tosndho = "Yes"
End If
strMyMsgResp = 6
strMyMsgResp = MsgBox("Do you want to SEND Reports," & vbLf & _
"?", vbYesNo + vbDefaultButton1)
If strMyMsgResp = 6 Then
Tosnd = "Yes"
End If
If Tosnd = "Yes" Then
Dim strMyMsgR
strMyMsgR = 7
strMyMsgR = MsgBox("DO YOU WANT TO ASK FOR S E N D I N G AT EACH PERSON ?:" & vbLf & _
"?", vbYesNo + vbDefaultButton2)
If strMyMsgR = 6 Then
Towaitsnd = "Yes"
End If
If Towaitsnd = "Yes" Then
strMyMsgR = MsgBox("SEND B.O. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Tosndmr = "Yes"
End If
strMyMsgR = MsgBox("SEND A.B.M. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Tosndabm = "Yes"
End If
strMyMsgR = MsgBox("SEND R.B.M. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Tosndrbm = "Yes"
End If
strMyMsgR = MsgBox("SEND Z.S.M. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Tosndzsm = "Yes"
End If
ToDel = "Yes"
Else
Tosndmr = "Yes"
Tosndabm = "Yes"
Tosndrbm = "Yes"
Tosndzsm = "Yes"
End If
strMyMsgR = 6
strMyMsgR = MsgBox("SEND **** Stockists Details ****" & vbLf & _
"?", vbYesNo + vbDefaultButton1)
If strMyMsgR = 6 Then
Tosndstk = "Yes"
strMyMsgR = 6
strMyMsgR = MsgBox("SEND Todays Details : YEs Full Details : NO (Only Aftermonthend or Saturday) ****" & vbLf & _
"?", vbYesNo + vbDefaultButton1)
If strMyMsgR = 6 Then
mfull = "No"
Else
mfull = "Yes"
End If
End If
End If
If Tosnd <> "Yes" Then
strMyMsgResp = 7
strMyMsgResp = MsgBox("Do you want to P R I N T Reports," & vbLf & _
"?", vbDefaultButton2 + vbYesNo, "Confirm Print!")
If strMyMsgResp = 6 Then
Toprn = "Yes"
strMyMsgR = MsgBox("DO YOU WANT TO ASK FOR PRINT AT EACH PERSON ?:" & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Towaitprn = "Yes"
End If
strMyMsgR = MsgBox("PRINT B.O. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Toprnmr = "Yes"
End If
strMyMsgR = MsgBox("PRINT A.B.M. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Toprnabm = "Yes"
End If
strMyMsgR = MsgBox("PRINT R.B.M. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Toprnrbm = "Yes"
End If
strMyMsgR = MsgBox("PRINT Z.S.M. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Toprnzsm = "Yes"
End If
End If
End If
Sheets("emailadd").Select
Cells.Select
Selection.ClearContents
Sheets("data").Select
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set Wb = ActiveWorkbook
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationAutomatic
End With
If tosndho = "Yes" Then
Sheets("Pnd_Report").Select
Range("A1").Select
If Worksheets("Pnd_Report").FilterMode = True Then
Selection.AutoFilter
End If
Selection.AutoFilter
Set rng = Nothing
abmlr = CStr(Cells(Rows.Count, 1).End(xlUp).Row)
Selection.AutoFilter Field:=11, Criteria1:="TRUE"
mcurrow = Cells(Rows.Count, 1).End(xlUp).Row
tonm = Range("L" & mcurrow).Value
If mcurrow > 2 Then
' Set rng = Range("c1:h" & abmlr).Offset(1, 0).SpecialCells(xlCellTypeVisible)
Set rng = Range("c1:h" & abmlr).SpecialCells(xlCellTypeVisible)
End If
On Error Resume Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = tonm
.Subject = "Pending Products @ Pune CFA"
mbody = "Dear sir, " & vbCr & vbCr
mbody = mbody & "Pl. find below list of Pending Products. Pl process if available." & vbCr
mbody = mbody & vbCr & "Thanks & Regards"
mbody = mbody & vbCr & "Pune CFA" & vbCr & vbCr & vbCr
mbody = mbody & RangetoHTML(rng)
.htmlBody = mbody
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Sheets("data").Select
Set Ash = ActiveSheet
Set FilterRange = Ash.Range("A1:AW" & Ash.Rows.Count)
Set Cws = Sheets("emailadd")
Sheets("emailadd").Select
Range("A1").Select
ActiveCell.FormulaR1C1 = "Address"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Name"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Filednumb"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Length"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Scrap"
Range("F1").Select
ActiveCell.FormulaR1C1 = "To_address"
Range("G1").Select
ActiveCell.FormulaR1C1 = "CC_address"
Range("h1").Select
ActiveCell.FormulaR1C1 = "ToSend"
Range("i1").Select
ActiveCell.FormulaR1C1 = "ToPrint"
mlr = Cells(Rows.Count, "A").End(xlUp).Row
mlr = mlr + 1
Sheets("data").Select
FieldNum = 40 'Filter column = B because the filter range start in column A
Set Cws = Sheets("emailadd")
If Tosndzsm = "Yes" Or Toprnzsm = "Yes" Then
FilterRange.Columns("AN").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A" & CStr(mlr)), _
CriteriaRange:="", Unique:=True
Sheets("Month_details").Select
formonth = "From : " & Range("A1").Value & " To : " & Range("B1").Value & " "
Sheets("emailadd").Select
Range("A" & CStr(mlr)).Select
Selection.EntireRow.Delete
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("C" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = 40
If Tosndzsm = "Yes" Then
Range("H" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
If Toprnzsm = "Yes" Then
Range("i" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
Range("C" & CStr(mlr)).Select
Selection.Copy
Range("C" & CStr(mlr) & ":c" & CStr(lr)).Select
ActiveSheet.Paste
Range("h" & CStr(mlr) & ":i" & CStr(mlr)).Select
Selection.Copy
Range("h" & CStr(mlr) & ":i" & CStr(lr)).Select
ActiveSheet.Paste
Range("A" & CStr(mlr) & ":A" & CStr(lr)).Select
Selection.Copy
Range("B" & CStr(mlr) & ":B" & CStr(lr)).Select
ActiveSheet.Paste
End If
Application.CutCopyMode = False
mlr = Cells(Rows.Count, "A").End(xlUp).Row
mlr = mlr + 1
Sheets("data").Select
FieldNum = 32 'Filter column = B because the filter range start in column A
If Tosndrbm = "Yes" Or Toprnrbm = "Yes" Then
FilterRange.Columns("AE:AF").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A" & CStr(mlr)), _
CriteriaRange:="", Unique:=True
Sheets("emailadd").Select
Range("A" & CStr(mlr)).Select
Selection.EntireRow.Delete
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("C" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = 32
If Tosndrbm = "Yes" Then
Range("H" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
If Toprnrbm = "Yes" Then
Range("i" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
Range("C" & CStr(mlr)).Select
Selection.Copy
Range("C" & CStr(mlr) & ":c" & CStr(lr)).Select
ActiveSheet.Paste
Range("h" & CStr(mlr) & ":i" & CStr(mlr)).Select
Selection.Copy
Range("h" & CStr(mlr) & ":i" & CStr(lr)).Select
ActiveSheet.Paste
End If
Application.CutCopyMode = False
mlr = Cells(Rows.Count, "A").End(xlUp).Row
mlr = mlr + 1
Sheets("data").Select
FieldNum = 34 'Filter column = B because the filter range start in column A
Set Cws = Sheets("emailadd")
If Tosndabm = "Yes" Or Toprnbm = "Yes" Then
FilterRange.Columns("AG:AH").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A" & CStr(mlr)), _
CriteriaRange:="", Unique:=True
Sheets("emailadd").Select
Range("A" & CStr(mlr)).Select
Selection.EntireRow.Delete
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("C" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = 34
If Tosndabm = "Yes" Then
Range("H" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
If Toprnabm = "Yes" Then
Range("i" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
Range("C" & CStr(mlr)).Select
Selection.Copy
Range("C" & CStr(mlr) & ":c" & CStr(lr)).Select
ActiveSheet.Paste
Range("h" & CStr(mlr) & ":i" & CStr(mlr)).Select
Selection.Copy
Range("h" & CStr(mlr) & ":i" & CStr(lr)).Select
ActiveSheet.Paste
End If
Application.CutCopyMode = False
mlr = Cells(Rows.Count, "A").End(xlUp).Row
mlr = mlr + 1
Sheets("data").Select
FieldNum = 36 'Filter column = B because the filter range start in column A
If Tosndmr = "Yes" Or Toprnmr = "Yes" Then
FilterRange.Columns("AI:AJ").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A" & CStr(mlr)), _
CriteriaRange:="", Unique:=True
Sheets("emailadd").Select
Range("A" & CStr(mlr)).Select
Selection.EntireRow.Delete
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("C" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = 36
If Tosndmr = "Yes" Then
Range("H" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
If Toprnmr = "Yes" Then
Range("i" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
Range("C" & CStr(mlr)).Select
Selection.Copy
Range("C" & CStr(mlr) & ":c" & CStr(lr)).Select
ActiveSheet.Paste
Range("h" & CStr(mlr) & ":i" & CStr(mlr)).Select
Selection.Copy
Range("h" & CStr(mlr) & ":i" & CStr(lr)).Select
ActiveSheet.Paste
End If
Application.CutCopyMode = False
Range("A1").Select
mlr = Cells(Rows.Count, "A").End(xlUp).Row
mlr = mlr + 1
Sheets("data").Select
Set Ash = ActiveSheet
Set FilterRange = Ash.Range("A1:Az" & Ash.Rows.Count)
FieldNum = 46 'Filter column = B because the filter range start in column A
If Tosndstk = "Yes" Then
Columns("AX:AZ").Select
Selection.ClearContents
'Add a worksheet for the unique list and copy the unique list in A1
Range("AX1").Select
ActiveCell.FormulaR1C1 = "Date_type"
Range("AW2").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("AX2").Select
ActiveCell.FormulaR1C1 = "=RC[-1]"
If mfull = "No" Then
Columns("AT:AU").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"AX1:AX2"), CopyToRange:=Columns("AY:AZ"), Unique:=False
Range("AY1").Select
'Worksheets.Add
FilterRange.Columns("AY:AY").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A" & CStr(mlr)), _
CriteriaRange:="", Unique:=True
Else
Range("At1").Select
'Worksheets.Add
FilterRange.Columns("At:At").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A" & CStr(mlr)), _
CriteriaRange:="", Unique:=True
End If
'Worksheets.Add
Sheets("emailadd").Select
Range("A" & CStr(mlr)).Select
Selection.EntireRow.Delete
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("C" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = 46
If Tosndstk = "Yes" Then
Range("H" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
Range("i" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "No"
Range("C" & CStr(mlr)).Select
Selection.Copy
Range("C" & CStr(mlr) & ":c" & CStr(lr)).Select
ActiveSheet.Paste
Range("h" & CStr(mlr) & ":i" & CStr(mlr)).Select
Selection.Copy
Range("h" & CStr(mlr) & ":i" & CStr(lr)).Select
ActiveSheet.Paste
Range("a" & CStr(mlr) & ":a" & CStr(lr)).Select
Selection.Copy
Range("b" & CStr(mlr) & ":b" & CStr(lr)).Select
ActiveSheet.Paste
End If
Application.CutCopyMode = False
Sheets("Emailadd").Select
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("D2").Select
ActiveCell.FormulaR1C1 = "=LEN(RC[-3])"
Range("D2").Select
Selection.Copy
Range("D2:D" & CStr(lr)).Select
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
Selection.AutoFilter
Selection.AutoFilter Field:=4, Criteria1:="<4"
Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Selection.AutoFilter
Range("A1").Select
Range("B2:B" & CStr(lr)).Select
Selection.Copy
Range("E2").Select
ActiveSheet.Paste
Range("A2:A" & CStr(lr)).Select
Selection.Copy
Range("B2").Select
ActiveSheet.Paste
Range("E2:E" & CStr(lr)).Select
Selection.Copy
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("F2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-2]>255,LEFT(RC[-5],FIND("";"",RC[-5],230)),RC[-5])"
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-3]>255,MID(RC[-6],FIND("";"",RC[-6],230)+1,255),"""")"
Range("F2:g2").Select
Selection.Copy
Range("f3:g" & CStr(lr)).Select
ActiveSheet.Paste
Range("A1").Select
mtime = Now()
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
Divname = ""
'If there are unique values start the loop
Tempwind = "Flash_PuneCFA " & Format(Now(), "dd-mm-yy")
Tempfilepath = Environ$("temp") & "\" & Tempwind
FileExtstr = ".xls"
Fileformatnum = -4143
On Error Resume Next
Kill (Environ$("temp") & "\*.xls")
On Error GoTo 0
If Rcount >= 2 Then
For Rnum = 2 To Rcount
Prnname = Range("B" & CStr(Rnum)).Value
Tosnd = Range("h" & CStr(Rnum)).Value
Toprnsht = Range("i" & CStr(Rnum)).Value
FieldNum = Range("C" & CStr(Rnum))
Application.StatusBar = " Progress : " & Rnum & " of " & Rcount & " " & Format(Rnum / Rcount, "Percent") & " " & Format(mtime, "hh:mm:ss") & " " & Format(Now(), "hh:mm:ss") & " For " & Left(Prnname, 30)
mcont = "Yes"
If (Toprnsht <> "Yes" And Tosnd <> "Yes") Then
mcont = "No"
End If
If Tosnd = "Yes" And Towaitsnd = "Yes" Then
strMyMsgR = MsgBox("SEND REPORT FOR :" & Prnname & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
mcont = "Yes"
Else
mcont = "No"
End If
End If
If Toprnsht = "Yes" And Towaitprn = "Yes" Then
strMyMsgR = MsgBox("PRINT REPORT FOR :" & Prnname & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
mcont = "Yes"
Else
mcont = "No"
End If
End If
If mcont = "Yes" Then
If Worksheets("Stock").FilterMode = True Then
Worksheets("Stock").AutoFilterMode = False
End If
'Filter the FilterRange on the FieldNum column
If Len(Cws.Cells(Rnum, 1).Value) < 250 Then
myrngg = Cws.Cells(Rnum, 1).Value
Else
myrngg = Mid(Cws.Cells(Rnum, 1).Value, 1, 40) & "*"
End If
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=myrngg
If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
With Application
.Calculation = xlCalculationManual
End With
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo error:
End With
rng.Copy
Set Dest = Workbooks.Add(xlWBATWorksheet)
Set rng = Nothing
Ash.AutoFilterMode = False
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
' .Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
' Application.DisplayAlerts = False
' Range("A1").Select
Columns("AU:AZ").Select
Selection.ClearContents
Cells.Select
If FieldNum <> 40 And FieldNum <> 46 Then
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Key2:=Range("F2") _
, Order2:=xlAscending, Key3:=Range("J2"), Order3:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False _
, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
xlSortNormal, DataOption3:=xlSortNormal
Range("B1").Select
End If
Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=14, Criteria1:="Pending"
mcurrow = .Cells(Rows.Count, 1).End(xlUp).Row
mpend = "No"
If mcurrow > 2 Then
mpend = "Yes"
End If
Selection.AutoFilter
Range("A1").Select
Sheets("Sheet1").Name = "Data"
Sheets("Data").Select
Divname = Range("C2").Value
ActiveWorkbook.Sheets("Data").Tab.ColorIndex = 3
lr = Cells(Rows.Count, "f").End(xlUp).Row
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
SourceData:="R1c1:R" & CStr(lr) & "c46").CreatePivotTable _
TableDestination:="", TableName:="PivotTable2", _
DefaultVersion:=xlPivotTableVersion10
On Error GoTo 0
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
' Set PT = ActiveSheet.PivotTables(1)
' PT.ManualUpdate = True
ActiveWindow.DisplayGridlines = False
ActiveSheet.PivotTables("PivotTable2").AddFields RowFields:= _
"Material Description", ColumnFields:="District name"
With ActiveSheet.PivotTables("PivotTable2")
' .HasAutoFormat = False
.PreserveFormatting = True
' .ShowDrillIndicators = False
' .SortUsingCustomLists = False
' .DisplayContextTooltips = False
End With
With ActiveSheet.PivotTables("PivotTable2").PivotFields("Net Qty.")
.Orientation = xlDataField
.Caption = "Net_Qty."
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable2").PivotFields("Net Flash")
.Orientation = xlDataField
.Caption = "Value"
.Position = 2
End With
ActiveSheet.PivotTables("PivotTable2").PivotFields("District name").Caption = _
"H.Q."
Range("A2").Select
ActiveCell.FormulaR1C1 = _
"Details of Headquarterwise - Productwise Qty. details."
Range("A27").Select
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "HQ_Quantity"
ActiveWorkbook.Sheets("HQ_Quantity").Tab.ColorIndex = 5
Rows("5:5").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
Columns("c:J").Select
With Selection.Font
.Size = 8
End With
Columns("c:J").NumberFormat = "0;-0;;@"
Columns("c:J").EntireColumn.AutoFit
Rows("4:4").Select
With Selection
.WrapText = True
End With
Range("A1").Select
Select Case FieldNum
Case 32
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[28], "" : "",MID(Data!R[1]C[30],1,20))"
Case 34
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[28], "" : "",MID(Data!R[1]C[32],1,20))"
Case 36
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[28], "" : "",MID(Data!R[1]C[34],1,22))"
Case 40
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[28], "" : Z S M "")"
End Select
Range("A1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Rows("3:3").Select
Selection.Insert Shift:=xlDown
Range("A3").Select
ActiveCell.FormulaR1C1 = formonth
Range("a1:A3").Select
With Selection.Font
.Size = 12
.Bold = True
End With
' On Error Resume Next
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
.PrintTitleColumns = "$A:$B"
If Toprn = "Yes" Then
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.63)
.BottomMargin = Application.InchesToPoints(0.59)
.HeaderMargin = Application.InchesToPoints(0.24)
.FooterMargin = Application.InchesToPoints(0.29)
.Orientation = xlPortrait
.PaperSize = xlPaperA4
End If
End With
' On Error GoTo 0
Range("A3").Select
If Toprnsht = "Yes" Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End If
' PT.ManualUpdate = False
' ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
' Set PT = Nothing
' Sales Flash
Sheets("Data").Select
Range("A1").Select
ActiveWorkbook.Worksheets("HQ_Quantity").PivotTables("PivotTable2").PivotCache. _
CreatePivotTable TableDestination:="", TableName:="PivotTable3", _
DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTables("PivotTable3").AddFields RowFields:=Array("Div_short" _
, "RBM", "abm", "District Name", "Name 1", "Data")
With ActiveSheet.PivotTables("PivotTable3")
' .HasAutoFormat = False
.PreserveFormatting = True
' .ShowDrillIndicators = False
' .SortUsingCustomLists = False
' .DisplayContextTooltips = False
End With
' Set PT = ActiveSheet.PivotTables(1)
' PT.ManualUpdate = True
' With ActiveSheet.PivotTables("PivotTable3")
' .HasAutoFormat = False
' .PreserveFormatting = True
' End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("Pending Val.")
.Orientation = xlDataField
.Position = 1
.Caption = "Pending Ord."
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("Inv. Value")
.Orientation = xlDataField
.Position = 2
.Caption = "Inv_Value"
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("C. N. Value")
.Orientation = xlDataField
.Position = 3
.Caption = "Exp/Brk. Val."
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("MRP Value")
.Orientation = xlDataField
.Position = 4
.Caption = "Sales Ret."
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("MRP")
.Orientation = xlDataField
.Position = 5
.Caption = "Rate Diff."
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("Net Flash")
.Orientation = xlDataField
.Position = 6
.Caption = "Net Sales"
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("Div_Short")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("B4").Select
With ActiveSheet.PivotTables("PivotTable3").PivotFields("RBM")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("C4").Select
With ActiveSheet.PivotTables("PivotTable3").PivotFields("abm")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("D4").Select
With ActiveSheet.PivotTables("PivotTable3").PivotFields("District name")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("F3").Select
With ActiveSheet.PivotTables("PivotTable3").DataPivotField
.Orientation = xlColumnField
.Position = 1
End With
Cells.Select
With Selection.Font
.Size = 8
End With
Columns("A:d").ColumnWidth = 2.5
Columns("E:E").ColumnWidth = 27
Application.CutCopyMode = False
Columns("F:K").Select
Selection.NumberFormat = "0;-0;;@"
Columns("F:K").EntireColumn.AutoFit
ActiveWindow.DisplayGridlines = False
' On Error GoTo 0
Rows("1:5").Select
Selection.Insert Shift:=xlDown
Range("A2").Select
ActiveCell.FormulaR1C1 = _
"Headquarterwise Salesh Flash With Pending Value"
Range("A3").Select
ActiveCell.FormulaR1C1 = _
"Pending Value will be converted subject to Availability of stock"
Range("A4").Select
ActiveCell.FormulaR1C1 = _
"and Subject to clearance of overdue outstanding"
Range("A1").Select
ActiveSheet.Name = "HQ_Flash"
ActiveWorkbook.Sheets("HQ_Flash").Tab.ColorIndex = 4
Rows("8:8").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
Range("D1").Select
Select Case FieldNum
Case 32
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[25], "" : "",MID(Data!R[1]C[27],1,20))"
Case 34
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[25], "" : "",MID(Data!R[1]C[29],1,20))"
Case 36
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[25], "" : "",MID(Data!R[1]C[31],1,22))"
Case 40
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[25], "" : Z S M"")"
End Select
Range("D1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With Selection.Font
.Size = 12
.Bold = True
End With
Range("A5").Select
ActiveCell.FormulaR1C1 = formonth
With Selection.Font
.Size = 12
.Bold = True
End With
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$7"
If Toprn = "Yes" Then
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.63)
.BottomMargin = Application.InchesToPoints(0.59)
.HeaderMargin = Application.InchesToPoints(0.24)
.FooterMargin = Application.InchesToPoints(0.29)
.Orientation = xlPortrait
.PrintGridlines = False
.PaperSize = xlPaperA4
End If
End With
If Toprnsht = "Yes" Then
If Towaitprn = "Yes" Then
strMyMsgR = MsgBox("PRINT REPORT FOR :" & Prnname & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End If
Else
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End If
End If
' PT.ManualUpdate = False
' ActiveSheet.PivotTables("PivotTable3").PivotCache.Refresh
' Set PT = Nothing
Sheets("DATA").Select
'For Pending qty reqport
If mpend = "Yes" Then
Sheets("DATA").Select
ActiveWorkbook.Worksheets("HQ_Quantity").PivotTables("PivotTable2").PivotCache. _
CreatePivotTable TableDestination:="", TableName:="PivotTable4", _
DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTables("PivotTable4").AddFields RowFields:=Array("HEAD", _
"RBM", "abm", "District name", "Material Description", "Data")
With ActiveSheet.PivotTables("PivotTable4")
' .HasAutoFormat = False
.PreserveFormatting = True
' .ShowDrillIndicators = False
' .SortUsingCustomLists = False
' .DisplayContextTooltips = False
End With
' Set PT = ActiveSheet.PivotTables(1)
With ActiveSheet.PivotTables("PivotTable4").PivotFields("Pend. Qty.")
.Orientation = xlDataField
.Position = 1
.Caption = "Pend_Qty."
End With
With ActiveSheet.PivotTables("PivotTable4").PivotFields("Pending Val.")
.Orientation = xlDataField
.Caption = "Pend_Value"
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable4").PivotFields("Pend. Qty.")
.Orientation = xlPageField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable4").PivotFields("Pend. Qty.").CurrentPage = _
"(All)"
With ActiveSheet.PivotTables("PivotTable4").DataPivotField
.Orientation = xlColumnField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable4").PivotFields("Pend. Qty."). _
EnableMultiplePageItems = True
On Error Resume Next
With ActiveSheet.PivotTables("PivotTable4").PivotFields("Pend. Qty.")
.PivotItems("").Visible = False
End With
' PT.ManualUpdate = True
On Error GoTo 0
Range("E7").Select
ActiveSheet.PivotTables("PivotTable4").RowGrand = False
Columns("G:G").Select
Selection.NumberFormat = "0"
Range("E5").Select
With ActiveSheet.PivotTables("PivotTable4").PivotFields("District name")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("C5").Select
With ActiveSheet.PivotTables("PivotTable4").PivotFields("abm")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("B5").Select
With ActiveSheet.PivotTables("PivotTable4").PivotFields("RBM")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("A5").Select
With ActiveSheet.PivotTables("PivotTable4").PivotFields("HEAD")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Columns("B:B").ColumnWidth = 5
Columns("C:C").ColumnWidth = 4.43
Columns("D:D").ColumnWidth = 7.29
Columns("E:E").EntireColumn.AutoFit
' Range("F8").Select
Columns("F:F").ColumnWidth = 10.86
Columns("G:G").ColumnWidth = 12.71
Columns("G:G").Select
Selection.NumberFormat = "0"
' Range("A6").Select
Columns("A:A").ColumnWidth = 5.71
Rows("1:5").Select
Selection.Insert Shift:=xlDown
Range("A2").Select
ActiveCell.FormulaR1C1 = _
"Headquarterwise Pending Order Value"
Range("A3").Select
ActiveCell.FormulaR1C1 = _
"Pending Value will be converted subject to Availability of stock"
Rows("9:9").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
Range("A5").Select
ActiveCell.FormulaR1C1 = formonth
With Selection.Font
.Size = 12
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
ActiveWindow.DisplayGridlines = False
' On Error Resume Next
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$8"
If Toprn = "Yes" Then
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.63)
.BottomMargin = Application.InchesToPoints(0.59)
.HeaderMargin = Application.InchesToPoints(0.24)
.FooterMargin = Application.InchesToPoints(0.29)
.PaperSize = xlPaperA4
End If
End With
ActiveSheet.Name = "Pnd_HQ_Sum."
ActiveWorkbook.Sheets("Pnd_HQ_Sum.").Tab.ColorIndex = 7
' PT.ManualUpdate = false
' Set PT = Nothing
Sheets("DATA").Select
ActiveWorkbook.Worksheets("HQ_Quantity").PivotTables("PivotTable2").PivotCache. _
CreatePivotTable TableDestination:="", TableName:="PivotTable5", _
DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTables("PivotTable5").AddFields RowFields:=Array("HEAD", _
"Material Description", "Data")
With ActiveSheet.PivotTables("PivotTable5")
' .HasAutoFormat = False
.PreserveFormatting = True
' .ShowDrillIndicators = False
' .SortUsingCustomLists = False
' .DisplayContextTooltips = False
End With
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Pend. Qty.")
.Orientation = xlDataField
.Position = 1
.Caption = "Pend_Qty."
End With
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Pending Val.")
.Orientation = xlDataField
.Caption = "Pend_Value"
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Pend. Qty.")
.Orientation = xlPageField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable5").PivotFields("Pend. Qty.").CurrentPage = _
"(All)"
With ActiveSheet.PivotTables("PivotTable5").DataPivotField
.Orientation = xlColumnField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable5").PivotFields("Pend. Qty."). _
EnableMultiplePageItems = True
On Error Resume Next
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Pend. Qty.")
.PivotItems("").Visible = False
End With
On Error GoTo 0
Range("G4").Select
With ActiveSheet.PivotTables("PivotTable5").DataPivotField
.Orientation = xlColumnField
.Position = 1
End With
Range("E7").Select
ActiveSheet.PivotTables("PivotTable5").RowGrand = False
Columns("d:d").Select
Selection.NumberFormat = "0"
Range("A5").Select
With ActiveSheet.PivotTables("PivotTable5").PivotFields("HEAD")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Columns("B:B").ColumnWidth = 5
Columns("C:C").ColumnWidth = 4.43
Columns("D:D").ColumnWidth = 7.29
Columns("E:E").EntireColumn.AutoFit
' Range("F8").Select
Columns("F:F").ColumnWidth = 10.86
Columns("G:G").ColumnWidth = 12.71
Columns("G:G").Select
Selection.NumberFormat = "0"
' Range("A6").Select
Columns("A:A").ColumnWidth = 5.71
Rows("1:5").Select
Selection.Insert Shift:=xlDown
Range("A2").Select
ActiveCell.FormulaR1C1 = _
"Pending Product Summary"
Range("A3").Select
ActiveCell.FormulaR1C1 = _
"Pending Value will be converted subject to Availability of stock"
Rows("9:9").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
Range("A5").Select
ActiveCell.FormulaR1C1 = formonth
With Selection.Font
.Size = 12
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
ActiveWindow.DisplayGridlines = False
' On Error Resume Next
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$8"
If Toprn = "Yes" Then
.PrintTitleColumns = ""
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.63)
.BottomMargin = Application.InchesToPoints(0.59)
.HeaderMargin = Application.InchesToPoints(0.24)
.FooterMargin = Application.InchesToPoints(0.29)
'.PrintQuality = 600
.Orientation = xlPortrait
.PaperSize = xlPaperA4
End If
End With
' On Error GoTo 0
ActiveSheet.Name = "Pnd_Prod_Sum."
ActiveWorkbook.Sheets("Pnd_Prod_Sum.").Tab.ColorIndex = 9
Columns("B:D").Select
Columns("B:D").EntireColumn.AutoFit
Range("A1").Select
End If
If FieldNum = 46 Then
Sheets("HQ_Quantity").Select
ActiveWindow.SelectedSheets.Delete
Sheets("HQ_Flash").Select
ActiveWindow.SelectedSheets.Delete
If mpend = "Yes" Then
Sheets("Pnd_HQ_Sum.").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Pnd_Prod_Sum.").Select
ActiveWindow.SelectedSheets.Delete
End If
Sheets("DATA").Select
Cells.Select
Selection.Sort Key1:=Range("j2"), Order1:=xlAscending, Key2:=Range("H2") _
, Order2:=xlAscending, Key3:=Range("L2"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
Cells.Select
Selection.RowHeight = 18
Columns("D:D").Select
Selection.EntireColumn.Hidden = True
Columns("E:E").Select
Selection.EntireColumn.Hidden = True
Columns("F:F").Select
Selection.EntireColumn.Hidden = True
Columns("G:G").Select
Selection.EntireColumn.Hidden = True
Columns("H:K").Select
Selection.ColumnWidth = 10.29
With Selection
.HorizontalAlignment = xlCenter
End With
Columns("L:L").EntireColumn.AutoFit
ActiveWindow.DisplayGridlines = False
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlHairline
End With
Columns("AC:AN").Select
Selection.Delete Shift:=xlToLeft
Columns("AE:AG").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End If
Rows("2:2").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
End With
If FieldNum <> 46 Then
Sheets("HQ_Flash").Select
Else
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Columns("M:U").Select
Selection.Delete Shift:=xlToLeft
Columns("R:R").Select
Selection.Delete Shift:=xlToLeft
Columns("N:O").Select
Selection.Cut
ActiveWindow.LargeScroll ToRight:=-1
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Columns("O:O").Select
Selection.Cut
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Range("G5").Select
Columns("G:G").ColumnWidth = 8.71
Columns("D:D").Select
Selection.Cut
Columns("R:R").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
Columns("B:B").ColumnWidth = 4.43
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Range("F1").Select
Columns("E:E").EntireColumn.AutoFit
Columns("I:I").EntireColumn.AutoFit
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 8
End With
Columns("A:E").EntireColumn.AutoFit
Range("D4").Select
Columns("B:B").ColumnWidth = 4.57
Range("F1").Select
stlr = Cells(Rows.Count, "c").End(xlUp).Row
Range("A1:Q" & CStr(stlr)).Sort Key1:=Range("E2"), Order1:=xlDescending, Key2:=Range _
("D2"), Order2:=xlAscending, Key3:=Range("J2"), Order3:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
DataOption3:=xlSortNormal
End If
Range("B1").Select
Tempfilename = CStr(Rnum)
If Dir(Tempfilepath & Tempfilename & FileExtstr) <> "" Then
Kill (Tempfilepath & Tempfilename & FileExtstr)
End If
With Application
.Calculation = xlCalculationAutomatic
End With
On Error GoTo 0
With Dest
' On Error GoTo error:
Tempfil = Tempfilepath & Tempfilename & FileExtstr
.SaveAs Tempfil, FileFormat:=Fileformatnum
If FieldNum = 32 Or FieldNum = 40 Then
Sheets("data").Select
stocknm = Range("AQ2").Value
Sheets.Add.Name = "Stock"
Windows("Party_send.xls").Activate
Sheets("stock").Select
Range("a1").Select
Sheets("stock").Select
If Worksheets("Stock").FilterMode = True Then
Selection.AutoFilter
End If
Selection.AutoFilter
ActiveSheet.Range("$A$1:$R$2500").AutoFilter Field:=3, Criteria1:= _
stocknm, Operator:=xlAnd
Cells.Select
Selection.Copy
Windows((Tempwind & Tempfilename & FileExtstr)).Activate
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("Stock").Select
lr = Cells(Rows.Count, "B").End(xlUp).Row
Sheets.Add.Name = "Stock_sum"
Cells(3, 1).Select
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Stock!R1C1:R" & CStr(lr) & "C18").CreatePivotTable _
TableDestination:="Stock_sum!R3C1", TableName:="PivotTable6", DefaultVersion _
:=xlPivotTableVersion10
' Set PT = ActiveSheet.PivotTables(1)
' PT.ManualUpdate = True
Sheets("stock_sum").Select
Cells(3, 1).Select
With ActiveSheet.PivotTables("PivotTable6")
' .HasAutoFormat = False
.PreserveFormatting = True
' .ShowDrillIndicators = False
' .SortUsingCustomLists = False
' .DisplayContextTooltips = False
End With
With ActiveSheet.PivotTables("PivotTable6").PivotFields("Name")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable6").PivotFields("Name")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
With ActiveSheet.PivotTables("PivotTable6").PivotFields("Material Description")
.Orientation = xlRowField
.Position = 2
End With
With ActiveSheet.PivotTables("PivotTable6").PivotFields("Material")
.Orientation = xlRowField
.Position = 3
End With
ActiveSheet.PivotTables("PivotTable6").AddDataField ActiveSheet.PivotTables( _
"PivotTable6").PivotFields("Stock"), "Sum of Stock", xlSum
Range("F10").Select
ActiveSheet.PivotTables("PivotTable6").PivotSelect _
"'Material Description'[All]", xlLabelOnly, True
Range("B4").Select
ActiveSheet.PivotTables("PivotTable6").PivotFields("Material Description"). _
Subtotals = Array(False, False, False, False, False, False, False, False, False, False, _
False, False)
Cells.Select
Selection.RowHeight = 17
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
Columns("A:A").ColumnWidth = 2.43
Columns("B:B").Select
With Selection
.HorizontalAlignment = xlRight
End With
Selection.InsertIndent 2
Columns("C:C").ColumnWidth = 11
With Selection
.HorizontalAlignment = xlCenter
End With
Columns("D:D").Select
With Selection
.HorizontalAlignment = xlCenter
End With
Selection.ColumnWidth = 9.71
Range("A1").Select
Rows("5:5").Select
ActiveWindow.FreezePanes = True
Range("B1").Select
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
End With
' PT.ManualUpdate = False
' ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
' Set PT = Nothing
Sheets("Stock").Delete
Sheets("data").Delete
Sheets("Hq_Flash").Select
Range("a1").Select
.SaveAs Tempfil, FileFormat:=Fileformatnum
End If
.Close savechanges = False
Sheets("emailadd").Select
If Tosnd = "Yes" Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
If FieldNum <> 46 Then
.Subject = formonth & " Transaction Details "
.Subject = Divname & " " & formonth & " - Salesh Flash - HQ - Product - Details "
.Body = smsgbody
Else
.Subject = formonth & " Transaction Details "
.Body = smstgbody
End If
.To = Cws.Cells(Rnum, 6).Value
.CC = Cws.Cells(Rnum, 7).Value
.Attachments.Add Tempfil
.deleteaftersubmit = True
.send 'Or use Send
End With
Set OutMail = Nothing
End If
Kill Tempfil
End With
' Kill Tempfilepath & Tempfilename & FileExtstr
End If
End If
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End
error:
MsgBox Err.Number & " " & Err.Description
Resume Next
End Sub
I have given below the macro which goes thru a excel file filters out data and creates a excel worksheet with multiple pivot table report.
using : MS Excel 2007, Microsoft Outlook 2007 & saving the report in Excel 2003 format.
Considering data of aroung 5000 lines it takes 8 to 10 seconds for each person
I would like to speed up the thing as sending to more thatn 300 persons on daily basis
Thanks in advance
Suhas
Sub Send_mail()
Dim OutApp As Object
Dim OutMail As Object
' Dim PT As PivotTable
' Dim PI As PivotItem
Dim lr As Integer
Dim stlr As Integer
Dim mlr As Integer
Dim rng As Range
Dim mrng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim Dtfilt As Date
Dim FilterRange As Range
Dim FieldNum As Integer
Dim formonth As String
Dim Source As Range
Dim Dest As Workbook
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim Tempwind As String
Dim mcont As String
Dim mfull As String
Dim TempWB As Workbook
Dim Tempfilepath As String
Dim Tempfilename As String
Dim FileExtstr As String
Dim Fileformatnum As Long
Dim Wb As Workbook
Dim Subj As String
Dim Lrow As Integer
Dim Tosnd As String
Dim Tosndstkall As String
Dim Toprn As String
Dim Toprnmr As String
Dim ToDel As String
Dim Toprnabm As String
Dim Toprnrbm As String
Dim Toprnzsm As String
Dim Tosndmr As String
Dim Tosndabm As String
Dim Tosndrbm As String
Dim Tosndzsm As String
Dim Tosndstk As String
Dim Toprnsht As String
Dim Towaitprn As String
Dim Towaitsnd As String
Dim Prnname As String
Dim divnm As String
Dim stocknm As String
Dim Sumamt As Integer
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = False
.Calculation = xlCalculationAutomatic
End With
Sheets("Data").Select
If Worksheets("Data").FilterMode = True Then
Selection.AutoFilter
End If
smsgbody = "Dear sir/madam," & vbCr & vbCr
smsgbody = smsgbody & "Please find enclosed herewith Excel file containing details of" & vbCr
smsgbody = smsgbody & "a. HQ-Flash" & vbCr
smsgbody = smsgbody & "b. HQ-Qty. Details" & vbCr
smsgbody = smsgbody & "c. HQ-wise Pending" & vbCr
smsgbody = smsgbody & "d. Pending Product" & vbCr
smsgbody = smsgbody & "e. DATA-Details" & vbCr
smsgbody = smsgbody & "" & vbCr
smsgbody = smsgbody & "The same is for your information." & vbCr
smsgbody = smsgbody & "" & vbCr
smsgbody = smsgbody & "CFA : H M Sales Corporation" & vbCr
smsgbody = smsgbody & "Godown No. 1,2, Behind Filtrum India" & vbCr
smsgbody = smsgbody & "Opp. Tata Johnson Controls" & vbCr
smsgbody = smsgbody & "Between Phase I & II, Taluka : Mulshi" & vbCr
smsgbody = smsgbody & "Hinjewadi : Pune : 411 057" & vbCr
smsgbody = smsgbody & "" & vbCr
smsgbody = smsgbody & "Phone : (020) 39821274 / 76 / 77 / 75" & vbCr
smsgbody = smsgbody & "" & vbCr
smsgbody = smsgbody & "Fax : (020) 39821265 / 83" & vbCr
smsgbody = smsgbody & "" & vbCr
smsgbody = smsgbody & "Thanks & Regards" & vbCr
smsgbody = smsgbody & "Pune C & F" & vbCr
smstgbody = "Dear sir/madam," & vbCr & vbCr
smstgbody = smstgbody & "Please find enclosed herewith Excel file containing transaction details." & vbCr
smstgbody = smstgbody & "" & vbCr
smstgbody = smstgbody & "The same is for your information." & vbCr
smstgbody = smstgbody & "" & vbCr
smstgbody = smstgbody & "CFA : H M Sales Corporation" & vbCr
smstgbody = smstgbody & "Godown No. 1,2, Behind Filtrum India" & vbCr
smstgbody = smstgbody & "Opp. Tata Johnson Controls" & vbCr
smstgbody = smstgbody & "Between Phase I & II, Taluka : Mulshi" & vbCr
smstgbody = smstgbody & "Hinjewadi : Pune : 411 057" & vbCr
smstgbody = smstgbody & "" & vbCr
smstgbody = smstgbody & "Phone : (020) 39821274 / 76 / 77 / 75" & vbCr
smstgbody = smstgbody & "" & vbCr
smstgbody = smstgbody & "Fax : (020) 39821265 / 83" & vbCr
smstgbody = smstgbody & "" & vbCr
smstgbody = smstgbody & "Thanks & Regards" & vbCr
smstgbody = smstgbody & "Pune C & F" & vbCr
Dim strMyMsgResp As Integer
ToDel = "Yes"
tosndho = "No"
strMyMsgResp = 6
strMyMsgResp = MsgBox("SEND PENDING PRODUCT Report to HO " & vbLf & _
"?", vbYesNo + vbDefaultButton2)
If strMyMsgResp = 6 Then
tosndho = "Yes"
End If
strMyMsgResp = 6
strMyMsgResp = MsgBox("Do you want to SEND Reports," & vbLf & _
"?", vbYesNo + vbDefaultButton1)
If strMyMsgResp = 6 Then
Tosnd = "Yes"
End If
If Tosnd = "Yes" Then
Dim strMyMsgR
strMyMsgR = 7
strMyMsgR = MsgBox("DO YOU WANT TO ASK FOR S E N D I N G AT EACH PERSON ?:" & vbLf & _
"?", vbYesNo + vbDefaultButton2)
If strMyMsgR = 6 Then
Towaitsnd = "Yes"
End If
If Towaitsnd = "Yes" Then
strMyMsgR = MsgBox("SEND B.O. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Tosndmr = "Yes"
End If
strMyMsgR = MsgBox("SEND A.B.M. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Tosndabm = "Yes"
End If
strMyMsgR = MsgBox("SEND R.B.M. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Tosndrbm = "Yes"
End If
strMyMsgR = MsgBox("SEND Z.S.M. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Tosndzsm = "Yes"
End If
ToDel = "Yes"
Else
Tosndmr = "Yes"
Tosndabm = "Yes"
Tosndrbm = "Yes"
Tosndzsm = "Yes"
End If
strMyMsgR = 6
strMyMsgR = MsgBox("SEND **** Stockists Details ****" & vbLf & _
"?", vbYesNo + vbDefaultButton1)
If strMyMsgR = 6 Then
Tosndstk = "Yes"
strMyMsgR = 6
strMyMsgR = MsgBox("SEND Todays Details : YEs Full Details : NO (Only Aftermonthend or Saturday) ****" & vbLf & _
"?", vbYesNo + vbDefaultButton1)
If strMyMsgR = 6 Then
mfull = "No"
Else
mfull = "Yes"
End If
End If
End If
If Tosnd <> "Yes" Then
strMyMsgResp = 7
strMyMsgResp = MsgBox("Do you want to P R I N T Reports," & vbLf & _
"?", vbDefaultButton2 + vbYesNo, "Confirm Print!")
If strMyMsgResp = 6 Then
Toprn = "Yes"
strMyMsgR = MsgBox("DO YOU WANT TO ASK FOR PRINT AT EACH PERSON ?:" & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Towaitprn = "Yes"
End If
strMyMsgR = MsgBox("PRINT B.O. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Toprnmr = "Yes"
End If
strMyMsgR = MsgBox("PRINT A.B.M. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Toprnabm = "Yes"
End If
strMyMsgR = MsgBox("PRINT R.B.M. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Toprnrbm = "Yes"
End If
strMyMsgR = MsgBox("PRINT Z.S.M. - FLASH & H.Q. QTY." & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
Toprnzsm = "Yes"
End If
End If
End If
Sheets("emailadd").Select
Cells.Select
Selection.ClearContents
Sheets("data").Select
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set Wb = ActiveWorkbook
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationAutomatic
End With
If tosndho = "Yes" Then
Sheets("Pnd_Report").Select
Range("A1").Select
If Worksheets("Pnd_Report").FilterMode = True Then
Selection.AutoFilter
End If
Selection.AutoFilter
Set rng = Nothing
abmlr = CStr(Cells(Rows.Count, 1).End(xlUp).Row)
Selection.AutoFilter Field:=11, Criteria1:="TRUE"
mcurrow = Cells(Rows.Count, 1).End(xlUp).Row
tonm = Range("L" & mcurrow).Value
If mcurrow > 2 Then
' Set rng = Range("c1:h" & abmlr).Offset(1, 0).SpecialCells(xlCellTypeVisible)
Set rng = Range("c1:h" & abmlr).SpecialCells(xlCellTypeVisible)
End If
On Error Resume Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = tonm
.Subject = "Pending Products @ Pune CFA"
mbody = "Dear sir, " & vbCr & vbCr
mbody = mbody & "Pl. find below list of Pending Products. Pl process if available." & vbCr
mbody = mbody & vbCr & "Thanks & Regards"
mbody = mbody & vbCr & "Pune CFA" & vbCr & vbCr & vbCr
mbody = mbody & RangetoHTML(rng)
.htmlBody = mbody
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Sheets("data").Select
Set Ash = ActiveSheet
Set FilterRange = Ash.Range("A1:AW" & Ash.Rows.Count)
Set Cws = Sheets("emailadd")
Sheets("emailadd").Select
Range("A1").Select
ActiveCell.FormulaR1C1 = "Address"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Name"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Filednumb"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Length"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Scrap"
Range("F1").Select
ActiveCell.FormulaR1C1 = "To_address"
Range("G1").Select
ActiveCell.FormulaR1C1 = "CC_address"
Range("h1").Select
ActiveCell.FormulaR1C1 = "ToSend"
Range("i1").Select
ActiveCell.FormulaR1C1 = "ToPrint"
mlr = Cells(Rows.Count, "A").End(xlUp).Row
mlr = mlr + 1
Sheets("data").Select
FieldNum = 40 'Filter column = B because the filter range start in column A
Set Cws = Sheets("emailadd")
If Tosndzsm = "Yes" Or Toprnzsm = "Yes" Then
FilterRange.Columns("AN").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A" & CStr(mlr)), _
CriteriaRange:="", Unique:=True
Sheets("Month_details").Select
formonth = "From : " & Range("A1").Value & " To : " & Range("B1").Value & " "
Sheets("emailadd").Select
Range("A" & CStr(mlr)).Select
Selection.EntireRow.Delete
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("C" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = 40
If Tosndzsm = "Yes" Then
Range("H" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
If Toprnzsm = "Yes" Then
Range("i" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
Range("C" & CStr(mlr)).Select
Selection.Copy
Range("C" & CStr(mlr) & ":c" & CStr(lr)).Select
ActiveSheet.Paste
Range("h" & CStr(mlr) & ":i" & CStr(mlr)).Select
Selection.Copy
Range("h" & CStr(mlr) & ":i" & CStr(lr)).Select
ActiveSheet.Paste
Range("A" & CStr(mlr) & ":A" & CStr(lr)).Select
Selection.Copy
Range("B" & CStr(mlr) & ":B" & CStr(lr)).Select
ActiveSheet.Paste
End If
Application.CutCopyMode = False
mlr = Cells(Rows.Count, "A").End(xlUp).Row
mlr = mlr + 1
Sheets("data").Select
FieldNum = 32 'Filter column = B because the filter range start in column A
If Tosndrbm = "Yes" Or Toprnrbm = "Yes" Then
FilterRange.Columns("AE:AF").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A" & CStr(mlr)), _
CriteriaRange:="", Unique:=True
Sheets("emailadd").Select
Range("A" & CStr(mlr)).Select
Selection.EntireRow.Delete
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("C" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = 32
If Tosndrbm = "Yes" Then
Range("H" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
If Toprnrbm = "Yes" Then
Range("i" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
Range("C" & CStr(mlr)).Select
Selection.Copy
Range("C" & CStr(mlr) & ":c" & CStr(lr)).Select
ActiveSheet.Paste
Range("h" & CStr(mlr) & ":i" & CStr(mlr)).Select
Selection.Copy
Range("h" & CStr(mlr) & ":i" & CStr(lr)).Select
ActiveSheet.Paste
End If
Application.CutCopyMode = False
mlr = Cells(Rows.Count, "A").End(xlUp).Row
mlr = mlr + 1
Sheets("data").Select
FieldNum = 34 'Filter column = B because the filter range start in column A
Set Cws = Sheets("emailadd")
If Tosndabm = "Yes" Or Toprnbm = "Yes" Then
FilterRange.Columns("AG:AH").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A" & CStr(mlr)), _
CriteriaRange:="", Unique:=True
Sheets("emailadd").Select
Range("A" & CStr(mlr)).Select
Selection.EntireRow.Delete
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("C" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = 34
If Tosndabm = "Yes" Then
Range("H" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
If Toprnabm = "Yes" Then
Range("i" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
Range("C" & CStr(mlr)).Select
Selection.Copy
Range("C" & CStr(mlr) & ":c" & CStr(lr)).Select
ActiveSheet.Paste
Range("h" & CStr(mlr) & ":i" & CStr(mlr)).Select
Selection.Copy
Range("h" & CStr(mlr) & ":i" & CStr(lr)).Select
ActiveSheet.Paste
End If
Application.CutCopyMode = False
mlr = Cells(Rows.Count, "A").End(xlUp).Row
mlr = mlr + 1
Sheets("data").Select
FieldNum = 36 'Filter column = B because the filter range start in column A
If Tosndmr = "Yes" Or Toprnmr = "Yes" Then
FilterRange.Columns("AI:AJ").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A" & CStr(mlr)), _
CriteriaRange:="", Unique:=True
Sheets("emailadd").Select
Range("A" & CStr(mlr)).Select
Selection.EntireRow.Delete
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("C" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = 36
If Tosndmr = "Yes" Then
Range("H" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
If Toprnmr = "Yes" Then
Range("i" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
Range("C" & CStr(mlr)).Select
Selection.Copy
Range("C" & CStr(mlr) & ":c" & CStr(lr)).Select
ActiveSheet.Paste
Range("h" & CStr(mlr) & ":i" & CStr(mlr)).Select
Selection.Copy
Range("h" & CStr(mlr) & ":i" & CStr(lr)).Select
ActiveSheet.Paste
End If
Application.CutCopyMode = False
Range("A1").Select
mlr = Cells(Rows.Count, "A").End(xlUp).Row
mlr = mlr + 1
Sheets("data").Select
Set Ash = ActiveSheet
Set FilterRange = Ash.Range("A1:Az" & Ash.Rows.Count)
FieldNum = 46 'Filter column = B because the filter range start in column A
If Tosndstk = "Yes" Then
Columns("AX:AZ").Select
Selection.ClearContents
'Add a worksheet for the unique list and copy the unique list in A1
Range("AX1").Select
ActiveCell.FormulaR1C1 = "Date_type"
Range("AW2").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("AX2").Select
ActiveCell.FormulaR1C1 = "=RC[-1]"
If mfull = "No" Then
Columns("AT:AU").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"AX1:AX2"), CopyToRange:=Columns("AY:AZ"), Unique:=False
Range("AY1").Select
'Worksheets.Add
FilterRange.Columns("AY:AY").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A" & CStr(mlr)), _
CriteriaRange:="", Unique:=True
Else
Range("At1").Select
'Worksheets.Add
FilterRange.Columns("At:At").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A" & CStr(mlr)), _
CriteriaRange:="", Unique:=True
End If
'Worksheets.Add
Sheets("emailadd").Select
Range("A" & CStr(mlr)).Select
Selection.EntireRow.Delete
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("C" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = 46
If Tosndstk = "Yes" Then
Range("H" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "Yes"
End If
Range("i" & CStr(mlr)).Select
ActiveCell.FormulaR1C1 = "No"
Range("C" & CStr(mlr)).Select
Selection.Copy
Range("C" & CStr(mlr) & ":c" & CStr(lr)).Select
ActiveSheet.Paste
Range("h" & CStr(mlr) & ":i" & CStr(mlr)).Select
Selection.Copy
Range("h" & CStr(mlr) & ":i" & CStr(lr)).Select
ActiveSheet.Paste
Range("a" & CStr(mlr) & ":a" & CStr(lr)).Select
Selection.Copy
Range("b" & CStr(mlr) & ":b" & CStr(lr)).Select
ActiveSheet.Paste
End If
Application.CutCopyMode = False
Sheets("Emailadd").Select
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("D2").Select
ActiveCell.FormulaR1C1 = "=LEN(RC[-3])"
Range("D2").Select
Selection.Copy
Range("D2:D" & CStr(lr)).Select
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
Selection.AutoFilter
Selection.AutoFilter Field:=4, Criteria1:="<4"
Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Selection.AutoFilter
Range("A1").Select
Range("B2:B" & CStr(lr)).Select
Selection.Copy
Range("E2").Select
ActiveSheet.Paste
Range("A2:A" & CStr(lr)).Select
Selection.Copy
Range("B2").Select
ActiveSheet.Paste
Range("E2:E" & CStr(lr)).Select
Selection.Copy
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("F2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-2]>255,LEFT(RC[-5],FIND("";"",RC[-5],230)),RC[-5])"
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-3]>255,MID(RC[-6],FIND("";"",RC[-6],230)+1,255),"""")"
Range("F2:g2").Select
Selection.Copy
Range("f3:g" & CStr(lr)).Select
ActiveSheet.Paste
Range("A1").Select
mtime = Now()
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
Divname = ""
'If there are unique values start the loop
Tempwind = "Flash_PuneCFA " & Format(Now(), "dd-mm-yy")
Tempfilepath = Environ$("temp") & "\" & Tempwind
FileExtstr = ".xls"
Fileformatnum = -4143
On Error Resume Next
Kill (Environ$("temp") & "\*.xls")
On Error GoTo 0
If Rcount >= 2 Then
For Rnum = 2 To Rcount
Prnname = Range("B" & CStr(Rnum)).Value
Tosnd = Range("h" & CStr(Rnum)).Value
Toprnsht = Range("i" & CStr(Rnum)).Value
FieldNum = Range("C" & CStr(Rnum))
Application.StatusBar = " Progress : " & Rnum & " of " & Rcount & " " & Format(Rnum / Rcount, "Percent") & " " & Format(mtime, "hh:mm:ss") & " " & Format(Now(), "hh:mm:ss") & " For " & Left(Prnname, 30)
mcont = "Yes"
If (Toprnsht <> "Yes" And Tosnd <> "Yes") Then
mcont = "No"
End If
If Tosnd = "Yes" And Towaitsnd = "Yes" Then
strMyMsgR = MsgBox("SEND REPORT FOR :" & Prnname & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
mcont = "Yes"
Else
mcont = "No"
End If
End If
If Toprnsht = "Yes" And Towaitprn = "Yes" Then
strMyMsgR = MsgBox("PRINT REPORT FOR :" & Prnname & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
mcont = "Yes"
Else
mcont = "No"
End If
End If
If mcont = "Yes" Then
If Worksheets("Stock").FilterMode = True Then
Worksheets("Stock").AutoFilterMode = False
End If
'Filter the FilterRange on the FieldNum column
If Len(Cws.Cells(Rnum, 1).Value) < 250 Then
myrngg = Cws.Cells(Rnum, 1).Value
Else
myrngg = Mid(Cws.Cells(Rnum, 1).Value, 1, 40) & "*"
End If
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=myrngg
If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
With Application
.Calculation = xlCalculationManual
End With
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo error:
End With
rng.Copy
Set Dest = Workbooks.Add(xlWBATWorksheet)
Set rng = Nothing
Ash.AutoFilterMode = False
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
' .Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
' Application.DisplayAlerts = False
' Range("A1").Select
Columns("AU:AZ").Select
Selection.ClearContents
Cells.Select
If FieldNum <> 40 And FieldNum <> 46 Then
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Key2:=Range("F2") _
, Order2:=xlAscending, Key3:=Range("J2"), Order3:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False _
, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
xlSortNormal, DataOption3:=xlSortNormal
Range("B1").Select
End If
Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=14, Criteria1:="Pending"
mcurrow = .Cells(Rows.Count, 1).End(xlUp).Row
mpend = "No"
If mcurrow > 2 Then
mpend = "Yes"
End If
Selection.AutoFilter
Range("A1").Select
Sheets("Sheet1").Name = "Data"
Sheets("Data").Select
Divname = Range("C2").Value
ActiveWorkbook.Sheets("Data").Tab.ColorIndex = 3
lr = Cells(Rows.Count, "f").End(xlUp).Row
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
SourceData:="R1c1:R" & CStr(lr) & "c46").CreatePivotTable _
TableDestination:="", TableName:="PivotTable2", _
DefaultVersion:=xlPivotTableVersion10
On Error GoTo 0
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
' Set PT = ActiveSheet.PivotTables(1)
' PT.ManualUpdate = True
ActiveWindow.DisplayGridlines = False
ActiveSheet.PivotTables("PivotTable2").AddFields RowFields:= _
"Material Description", ColumnFields:="District name"
With ActiveSheet.PivotTables("PivotTable2")
' .HasAutoFormat = False
.PreserveFormatting = True
' .ShowDrillIndicators = False
' .SortUsingCustomLists = False
' .DisplayContextTooltips = False
End With
With ActiveSheet.PivotTables("PivotTable2").PivotFields("Net Qty.")
.Orientation = xlDataField
.Caption = "Net_Qty."
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable2").PivotFields("Net Flash")
.Orientation = xlDataField
.Caption = "Value"
.Position = 2
End With
ActiveSheet.PivotTables("PivotTable2").PivotFields("District name").Caption = _
"H.Q."
Range("A2").Select
ActiveCell.FormulaR1C1 = _
"Details of Headquarterwise - Productwise Qty. details."
Range("A27").Select
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "HQ_Quantity"
ActiveWorkbook.Sheets("HQ_Quantity").Tab.ColorIndex = 5
Rows("5:5").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
Columns("c:J").Select
With Selection.Font
.Size = 8
End With
Columns("c:J").NumberFormat = "0;-0;;@"
Columns("c:J").EntireColumn.AutoFit
Rows("4:4").Select
With Selection
.WrapText = True
End With
Range("A1").Select
Select Case FieldNum
Case 32
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[28], "" : "",MID(Data!R[1]C[30],1,20))"
Case 34
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[28], "" : "",MID(Data!R[1]C[32],1,20))"
Case 36
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[28], "" : "",MID(Data!R[1]C[34],1,22))"
Case 40
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[28], "" : Z S M "")"
End Select
Range("A1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Rows("3:3").Select
Selection.Insert Shift:=xlDown
Range("A3").Select
ActiveCell.FormulaR1C1 = formonth
Range("a1:A3").Select
With Selection.Font
.Size = 12
.Bold = True
End With
' On Error Resume Next
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
.PrintTitleColumns = "$A:$B"
If Toprn = "Yes" Then
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.63)
.BottomMargin = Application.InchesToPoints(0.59)
.HeaderMargin = Application.InchesToPoints(0.24)
.FooterMargin = Application.InchesToPoints(0.29)
.Orientation = xlPortrait
.PaperSize = xlPaperA4
End If
End With
' On Error GoTo 0
Range("A3").Select
If Toprnsht = "Yes" Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End If
' PT.ManualUpdate = False
' ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
' Set PT = Nothing
' Sales Flash
Sheets("Data").Select
Range("A1").Select
ActiveWorkbook.Worksheets("HQ_Quantity").PivotTables("PivotTable2").PivotCache. _
CreatePivotTable TableDestination:="", TableName:="PivotTable3", _
DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTables("PivotTable3").AddFields RowFields:=Array("Div_short" _
, "RBM", "abm", "District Name", "Name 1", "Data")
With ActiveSheet.PivotTables("PivotTable3")
' .HasAutoFormat = False
.PreserveFormatting = True
' .ShowDrillIndicators = False
' .SortUsingCustomLists = False
' .DisplayContextTooltips = False
End With
' Set PT = ActiveSheet.PivotTables(1)
' PT.ManualUpdate = True
' With ActiveSheet.PivotTables("PivotTable3")
' .HasAutoFormat = False
' .PreserveFormatting = True
' End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("Pending Val.")
.Orientation = xlDataField
.Position = 1
.Caption = "Pending Ord."
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("Inv. Value")
.Orientation = xlDataField
.Position = 2
.Caption = "Inv_Value"
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("C. N. Value")
.Orientation = xlDataField
.Position = 3
.Caption = "Exp/Brk. Val."
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("MRP Value")
.Orientation = xlDataField
.Position = 4
.Caption = "Sales Ret."
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("MRP")
.Orientation = xlDataField
.Position = 5
.Caption = "Rate Diff."
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("Net Flash")
.Orientation = xlDataField
.Position = 6
.Caption = "Net Sales"
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("Div_Short")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("B4").Select
With ActiveSheet.PivotTables("PivotTable3").PivotFields("RBM")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("C4").Select
With ActiveSheet.PivotTables("PivotTable3").PivotFields("abm")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("D4").Select
With ActiveSheet.PivotTables("PivotTable3").PivotFields("District name")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("F3").Select
With ActiveSheet.PivotTables("PivotTable3").DataPivotField
.Orientation = xlColumnField
.Position = 1
End With
Cells.Select
With Selection.Font
.Size = 8
End With
Columns("A:d").ColumnWidth = 2.5
Columns("E:E").ColumnWidth = 27
Application.CutCopyMode = False
Columns("F:K").Select
Selection.NumberFormat = "0;-0;;@"
Columns("F:K").EntireColumn.AutoFit
ActiveWindow.DisplayGridlines = False
' On Error GoTo 0
Rows("1:5").Select
Selection.Insert Shift:=xlDown
Range("A2").Select
ActiveCell.FormulaR1C1 = _
"Headquarterwise Salesh Flash With Pending Value"
Range("A3").Select
ActiveCell.FormulaR1C1 = _
"Pending Value will be converted subject to Availability of stock"
Range("A4").Select
ActiveCell.FormulaR1C1 = _
"and Subject to clearance of overdue outstanding"
Range("A1").Select
ActiveSheet.Name = "HQ_Flash"
ActiveWorkbook.Sheets("HQ_Flash").Tab.ColorIndex = 4
Rows("8:8").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
Range("D1").Select
Select Case FieldNum
Case 32
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[25], "" : "",MID(Data!R[1]C[27],1,20))"
Case 34
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[25], "" : "",MID(Data!R[1]C[29],1,20))"
Case 36
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[25], "" : "",MID(Data!R[1]C[31],1,22))"
Case 40
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(Data!R[1]C[25], "" : Z S M"")"
End Select
Range("D1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With Selection.Font
.Size = 12
.Bold = True
End With
Range("A5").Select
ActiveCell.FormulaR1C1 = formonth
With Selection.Font
.Size = 12
.Bold = True
End With
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$7"
If Toprn = "Yes" Then
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.63)
.BottomMargin = Application.InchesToPoints(0.59)
.HeaderMargin = Application.InchesToPoints(0.24)
.FooterMargin = Application.InchesToPoints(0.29)
.Orientation = xlPortrait
.PrintGridlines = False
.PaperSize = xlPaperA4
End If
End With
If Toprnsht = "Yes" Then
If Towaitprn = "Yes" Then
strMyMsgR = MsgBox("PRINT REPORT FOR :" & Prnname & vbLf & _
"?", vbQuestion + vbYesNo)
If strMyMsgR = 6 Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End If
Else
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End If
End If
' PT.ManualUpdate = False
' ActiveSheet.PivotTables("PivotTable3").PivotCache.Refresh
' Set PT = Nothing
Sheets("DATA").Select
'For Pending qty reqport
If mpend = "Yes" Then
Sheets("DATA").Select
ActiveWorkbook.Worksheets("HQ_Quantity").PivotTables("PivotTable2").PivotCache. _
CreatePivotTable TableDestination:="", TableName:="PivotTable4", _
DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTables("PivotTable4").AddFields RowFields:=Array("HEAD", _
"RBM", "abm", "District name", "Material Description", "Data")
With ActiveSheet.PivotTables("PivotTable4")
' .HasAutoFormat = False
.PreserveFormatting = True
' .ShowDrillIndicators = False
' .SortUsingCustomLists = False
' .DisplayContextTooltips = False
End With
' Set PT = ActiveSheet.PivotTables(1)
With ActiveSheet.PivotTables("PivotTable4").PivotFields("Pend. Qty.")
.Orientation = xlDataField
.Position = 1
.Caption = "Pend_Qty."
End With
With ActiveSheet.PivotTables("PivotTable4").PivotFields("Pending Val.")
.Orientation = xlDataField
.Caption = "Pend_Value"
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable4").PivotFields("Pend. Qty.")
.Orientation = xlPageField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable4").PivotFields("Pend. Qty.").CurrentPage = _
"(All)"
With ActiveSheet.PivotTables("PivotTable4").DataPivotField
.Orientation = xlColumnField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable4").PivotFields("Pend. Qty."). _
EnableMultiplePageItems = True
On Error Resume Next
With ActiveSheet.PivotTables("PivotTable4").PivotFields("Pend. Qty.")
.PivotItems("").Visible = False
End With
' PT.ManualUpdate = True
On Error GoTo 0
Range("E7").Select
ActiveSheet.PivotTables("PivotTable4").RowGrand = False
Columns("G:G").Select
Selection.NumberFormat = "0"
Range("E5").Select
With ActiveSheet.PivotTables("PivotTable4").PivotFields("District name")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("C5").Select
With ActiveSheet.PivotTables("PivotTable4").PivotFields("abm")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("B5").Select
With ActiveSheet.PivotTables("PivotTable4").PivotFields("RBM")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Range("A5").Select
With ActiveSheet.PivotTables("PivotTable4").PivotFields("HEAD")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Columns("B:B").ColumnWidth = 5
Columns("C:C").ColumnWidth = 4.43
Columns("D:D").ColumnWidth = 7.29
Columns("E:E").EntireColumn.AutoFit
' Range("F8").Select
Columns("F:F").ColumnWidth = 10.86
Columns("G:G").ColumnWidth = 12.71
Columns("G:G").Select
Selection.NumberFormat = "0"
' Range("A6").Select
Columns("A:A").ColumnWidth = 5.71
Rows("1:5").Select
Selection.Insert Shift:=xlDown
Range("A2").Select
ActiveCell.FormulaR1C1 = _
"Headquarterwise Pending Order Value"
Range("A3").Select
ActiveCell.FormulaR1C1 = _
"Pending Value will be converted subject to Availability of stock"
Rows("9:9").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
Range("A5").Select
ActiveCell.FormulaR1C1 = formonth
With Selection.Font
.Size = 12
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
ActiveWindow.DisplayGridlines = False
' On Error Resume Next
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$8"
If Toprn = "Yes" Then
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.63)
.BottomMargin = Application.InchesToPoints(0.59)
.HeaderMargin = Application.InchesToPoints(0.24)
.FooterMargin = Application.InchesToPoints(0.29)
.PaperSize = xlPaperA4
End If
End With
ActiveSheet.Name = "Pnd_HQ_Sum."
ActiveWorkbook.Sheets("Pnd_HQ_Sum.").Tab.ColorIndex = 7
' PT.ManualUpdate = false
' Set PT = Nothing
Sheets("DATA").Select
ActiveWorkbook.Worksheets("HQ_Quantity").PivotTables("PivotTable2").PivotCache. _
CreatePivotTable TableDestination:="", TableName:="PivotTable5", _
DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTables("PivotTable5").AddFields RowFields:=Array("HEAD", _
"Material Description", "Data")
With ActiveSheet.PivotTables("PivotTable5")
' .HasAutoFormat = False
.PreserveFormatting = True
' .ShowDrillIndicators = False
' .SortUsingCustomLists = False
' .DisplayContextTooltips = False
End With
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Pend. Qty.")
.Orientation = xlDataField
.Position = 1
.Caption = "Pend_Qty."
End With
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Pending Val.")
.Orientation = xlDataField
.Caption = "Pend_Value"
.Function = xlSum
End With
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Pend. Qty.")
.Orientation = xlPageField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable5").PivotFields("Pend. Qty.").CurrentPage = _
"(All)"
With ActiveSheet.PivotTables("PivotTable5").DataPivotField
.Orientation = xlColumnField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable5").PivotFields("Pend. Qty."). _
EnableMultiplePageItems = True
On Error Resume Next
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Pend. Qty.")
.PivotItems("").Visible = False
End With
On Error GoTo 0
Range("G4").Select
With ActiveSheet.PivotTables("PivotTable5").DataPivotField
.Orientation = xlColumnField
.Position = 1
End With
Range("E7").Select
ActiveSheet.PivotTables("PivotTable5").RowGrand = False
Columns("d:d").Select
Selection.NumberFormat = "0"
Range("A5").Select
With ActiveSheet.PivotTables("PivotTable5").PivotFields("HEAD")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
Columns("B:B").ColumnWidth = 5
Columns("C:C").ColumnWidth = 4.43
Columns("D:D").ColumnWidth = 7.29
Columns("E:E").EntireColumn.AutoFit
' Range("F8").Select
Columns("F:F").ColumnWidth = 10.86
Columns("G:G").ColumnWidth = 12.71
Columns("G:G").Select
Selection.NumberFormat = "0"
' Range("A6").Select
Columns("A:A").ColumnWidth = 5.71
Rows("1:5").Select
Selection.Insert Shift:=xlDown
Range("A2").Select
ActiveCell.FormulaR1C1 = _
"Pending Product Summary"
Range("A3").Select
ActiveCell.FormulaR1C1 = _
"Pending Value will be converted subject to Availability of stock"
Rows("9:9").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
Range("A5").Select
ActiveCell.FormulaR1C1 = formonth
With Selection.Font
.Size = 12
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
ActiveWindow.DisplayGridlines = False
' On Error Resume Next
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$8"
If Toprn = "Yes" Then
.PrintTitleColumns = ""
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.63)
.BottomMargin = Application.InchesToPoints(0.59)
.HeaderMargin = Application.InchesToPoints(0.24)
.FooterMargin = Application.InchesToPoints(0.29)
'.PrintQuality = 600
.Orientation = xlPortrait
.PaperSize = xlPaperA4
End If
End With
' On Error GoTo 0
ActiveSheet.Name = "Pnd_Prod_Sum."
ActiveWorkbook.Sheets("Pnd_Prod_Sum.").Tab.ColorIndex = 9
Columns("B:D").Select
Columns("B:D").EntireColumn.AutoFit
Range("A1").Select
End If
If FieldNum = 46 Then
Sheets("HQ_Quantity").Select
ActiveWindow.SelectedSheets.Delete
Sheets("HQ_Flash").Select
ActiveWindow.SelectedSheets.Delete
If mpend = "Yes" Then
Sheets("Pnd_HQ_Sum.").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Pnd_Prod_Sum.").Select
ActiveWindow.SelectedSheets.Delete
End If
Sheets("DATA").Select
Cells.Select
Selection.Sort Key1:=Range("j2"), Order1:=xlAscending, Key2:=Range("H2") _
, Order2:=xlAscending, Key3:=Range("L2"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
Cells.Select
Selection.RowHeight = 18
Columns("D:D").Select
Selection.EntireColumn.Hidden = True
Columns("E:E").Select
Selection.EntireColumn.Hidden = True
Columns("F:F").Select
Selection.EntireColumn.Hidden = True
Columns("G:G").Select
Selection.EntireColumn.Hidden = True
Columns("H:K").Select
Selection.ColumnWidth = 10.29
With Selection
.HorizontalAlignment = xlCenter
End With
Columns("L:L").EntireColumn.AutoFit
ActiveWindow.DisplayGridlines = False
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlHairline
End With
Columns("AC:AN").Select
Selection.Delete Shift:=xlToLeft
Columns("AE:AG").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End If
Rows("2:2").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
End With
If FieldNum <> 46 Then
Sheets("HQ_Flash").Select
Else
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Columns("M:U").Select
Selection.Delete Shift:=xlToLeft
Columns("R:R").Select
Selection.Delete Shift:=xlToLeft
Columns("N:O").Select
Selection.Cut
ActiveWindow.LargeScroll ToRight:=-1
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Columns("O:O").Select
Selection.Cut
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Range("G5").Select
Columns("G:G").ColumnWidth = 8.71
Columns("D:D").Select
Selection.Cut
Columns("R:R").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
Columns("B:B").ColumnWidth = 4.43
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Range("F1").Select
Columns("E:E").EntireColumn.AutoFit
Columns("I:I").EntireColumn.AutoFit
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 8
End With
Columns("A:E").EntireColumn.AutoFit
Range("D4").Select
Columns("B:B").ColumnWidth = 4.57
Range("F1").Select
stlr = Cells(Rows.Count, "c").End(xlUp).Row
Range("A1:Q" & CStr(stlr)).Sort Key1:=Range("E2"), Order1:=xlDescending, Key2:=Range _
("D2"), Order2:=xlAscending, Key3:=Range("J2"), Order3:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
DataOption3:=xlSortNormal
End If
Range("B1").Select
Tempfilename = CStr(Rnum)
If Dir(Tempfilepath & Tempfilename & FileExtstr) <> "" Then
Kill (Tempfilepath & Tempfilename & FileExtstr)
End If
With Application
.Calculation = xlCalculationAutomatic
End With
On Error GoTo 0
With Dest
' On Error GoTo error:
Tempfil = Tempfilepath & Tempfilename & FileExtstr
.SaveAs Tempfil, FileFormat:=Fileformatnum
If FieldNum = 32 Or FieldNum = 40 Then
Sheets("data").Select
stocknm = Range("AQ2").Value
Sheets.Add.Name = "Stock"
Windows("Party_send.xls").Activate
Sheets("stock").Select
Range("a1").Select
Sheets("stock").Select
If Worksheets("Stock").FilterMode = True Then
Selection.AutoFilter
End If
Selection.AutoFilter
ActiveSheet.Range("$A$1:$R$2500").AutoFilter Field:=3, Criteria1:= _
stocknm, Operator:=xlAnd
Cells.Select
Selection.Copy
Windows((Tempwind & Tempfilename & FileExtstr)).Activate
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("Stock").Select
lr = Cells(Rows.Count, "B").End(xlUp).Row
Sheets.Add.Name = "Stock_sum"
Cells(3, 1).Select
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Stock!R1C1:R" & CStr(lr) & "C18").CreatePivotTable _
TableDestination:="Stock_sum!R3C1", TableName:="PivotTable6", DefaultVersion _
:=xlPivotTableVersion10
' Set PT = ActiveSheet.PivotTables(1)
' PT.ManualUpdate = True
Sheets("stock_sum").Select
Cells(3, 1).Select
With ActiveSheet.PivotTables("PivotTable6")
' .HasAutoFormat = False
.PreserveFormatting = True
' .ShowDrillIndicators = False
' .SortUsingCustomLists = False
' .DisplayContextTooltips = False
End With
With ActiveSheet.PivotTables("PivotTable6").PivotFields("Name")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable6").PivotFields("Name")
.LayoutBlankLine = True
.LayoutForm = xlOutline
End With
With ActiveSheet.PivotTables("PivotTable6").PivotFields("Material Description")
.Orientation = xlRowField
.Position = 2
End With
With ActiveSheet.PivotTables("PivotTable6").PivotFields("Material")
.Orientation = xlRowField
.Position = 3
End With
ActiveSheet.PivotTables("PivotTable6").AddDataField ActiveSheet.PivotTables( _
"PivotTable6").PivotFields("Stock"), "Sum of Stock", xlSum
Range("F10").Select
ActiveSheet.PivotTables("PivotTable6").PivotSelect _
"'Material Description'[All]", xlLabelOnly, True
Range("B4").Select
ActiveSheet.PivotTables("PivotTable6").PivotFields("Material Description"). _
Subtotals = Array(False, False, False, False, False, False, False, False, False, False, _
False, False)
Cells.Select
Selection.RowHeight = 17
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
Columns("A:A").ColumnWidth = 2.43
Columns("B:B").Select
With Selection
.HorizontalAlignment = xlRight
End With
Selection.InsertIndent 2
Columns("C:C").ColumnWidth = 11
With Selection
.HorizontalAlignment = xlCenter
End With
Columns("D:D").Select
With Selection
.HorizontalAlignment = xlCenter
End With
Selection.ColumnWidth = 9.71
Range("A1").Select
Rows("5:5").Select
ActiveWindow.FreezePanes = True
Range("B1").Select
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
End With
' PT.ManualUpdate = False
' ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
' Set PT = Nothing
Sheets("Stock").Delete
Sheets("data").Delete
Sheets("Hq_Flash").Select
Range("a1").Select
.SaveAs Tempfil, FileFormat:=Fileformatnum
End If
.Close savechanges = False
Sheets("emailadd").Select
If Tosnd = "Yes" Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
If FieldNum <> 46 Then
.Subject = formonth & " Transaction Details "
.Subject = Divname & " " & formonth & " - Salesh Flash - HQ - Product - Details "
.Body = smsgbody
Else
.Subject = formonth & " Transaction Details "
.Body = smstgbody
End If
.To = Cws.Cells(Rnum, 6).Value
.CC = Cws.Cells(Rnum, 7).Value
.Attachments.Add Tempfil
.deleteaftersubmit = True
.send 'Or use Send
End With
Set OutMail = Nothing
End If
Kill Tempfil
End With
' Kill Tempfilepath & Tempfilename & FileExtstr
End If
End If
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End
error:
MsgBox Err.Number & " " & Err.Description
Resume Next
End Sub
