balaji3081
Member
Guys need help, not sure if this is enough or you need more details -
Code:
Public oApp As Object
Public strDB As String
Public Wbk_Base As Workbook
Public strPDF As String
Public Sub Initialize()
Application.DisplayAlerts = False
strDB = Worksheets("Input").Range("B2")
'strPDF = Worksheets("Input").Range("B11")
End Sub
Sub ExportAsPDF()
Dim fileName As String
fileName = strPDF
'ThisWorkbook.Sheets(Array().Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
fileName:=fileName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub
Public Sub OpenDB(strDB)
Set oApp = CreateObject("Access.Application")
oApp.Visible = False
'// Open database
oApp.OpenCurrentDatabase strDB
End Sub
Public Sub GetData(ParamArray qryParams())
Dim oQry As Object
Dim rs As Object
Dim i As Integer
Set oQry = oApp.CurrentDB.Querydefs(qryParams(0))
j = 1
For i = 0 To oQry.Parameters.Count - 1
oQry.Parameters(i).Value = qryParams(j)
j = j + 1
Next
Set rs = oQry.Openrecordset
s = ActiveSheet.Range("B4")
Set Wbk_Base = Workbooks.Open(ThisWorkbook.Path & "\Base File.xlsx")
Wbk_Base.Sheets(s).Select
'Wbk_Base.Sheets(s).Range("A2:Y119").ClearContents
Range("A2", Range("Y2").End(xlDown)).Clear
Wbk_Base.Sheets(s).Range("A2").CopyFromRecordset rs
rngrow = 1
rngcolumn = 1
For i = 1 To rs.Fields.Count
Wbk_Base.ActiveSheet.Cells(rngrow, rngcolumn).Value = rs.Fields(i - 1).Name
rngcolumn = rngcolumn + 1
Next i
oQry.Close
rs.Close
Set oQry = Nothing
Set rs = Nothing
End Sub
Public Sub Main()
Dim nRows As Integer
Dim WbBase As Workbook
Dim sOutPutPath As String
Dim sOutPutFile As String
Dim ppRecepient, ppCCRecepient, ppAttachment As String
Dim pRecepient, pCCRecepient, pSubject, pMessage, pAttachment, pSendMsg As String
Dim colAttachments As Collection
Dim vProject, vCurrency, vProjectDept, vProjGOCOff As String
Call Initialize
Call OpenDB(strDB)
'*****
nRows = Worksheets("Input").Range("A9").CurrentRegion.Rows.Count + 7
With ThisWorkbook.Worksheets("Input")
sOutPutPath = .Range("B6") & "\"
'pMessage = .Range("G2")
'pSendMsg = .Range("G4")
End With
For i = 9 To nRows
If Sheet1.Range("A" & i) <> "" Then
Call GetData(Sheet1.Range("B3"), Sheet1.Range("A" & i), Sheet1.Range("B" & i), Sheet1.Range("C" & i), Sheet1.Range("D" & i), Sheet1.Range("E" & i))
End If
Wbk_Base.Worksheets("Current Month Summary").Select
With ThisWorkbook.Worksheets("Input")
sOutPutFile = sOutPutPath & .Range("F" & i)
End With
vL6 = Sheet1.Range("A" & i)
vStart_Period = Sheet1.Range("B" & i)
vEnd_period = Sheet1.Range("C" & i)
On Error Resume Next
With Wbk_Base.Sheets("Current Month Summary")
.PivotTables("PivotTable1").PivotCache.Refresh
.Range("B6") = IIf(vMASTER_NAME <> "", vMASTER_NAME, "(All)")
.Range("B7") = IIf(vOFFICE <> "", vOFFICE, "(All)")
.Range("B8") = IIf(vLOCATION <> "", vLOCATION, "(All)")
.Range("B9") = IIf(vMTH <> "", vMTH, "(All)")
.PivotTables("PivotTable1").PivotCache.Refresh
With Wbk_Base.Sheets("YTD Summary")
.PivotTables("PivotTable1").PivotCache.Refresh
.Range("B6") = IIf(vMASTER_NAME <> "", vMASTER_NAME, "(All)")
.Range("B7") = IIf(vOFFICE <> "", vOFFICE, "(All)")
.Range("B8") = IIf(vLOCATION <> "", vLOCATION, "(All)")
.Range("B9") = IIf(vYTD <> "", vYTD, "(All)")
.PivotTables("PivotTable2").PivotCache.Refresh
With Wbk_Base.Sheets("12 Month Rolling Summary")
.PivotTables("PivotTable1").PivotCache.Refresh
.Range("B6") = IIf(vMASTER_NAME <> "", vMASTER_NAME, "(All)")
.Range("B7") = IIf(vOFFICE <> "", vOFFICE, "(All)")
.Range("B8") = IIf(vLOCATION <> "", vLOCATION, "(All)")
.PivotTables("PivotTable3").PivotCache.Refresh
End With
If Err.Number = 0 Then
Wbk_Base.SaveAs sOutPutFile
Wbk_Base.Close
'Call SendMail(pSubject, pRecepient, pCCRecepient, pMessage, pAttachment, pSendMsg)
Else
Err.Number = 0
Wbk_Base.Close
End If
Next i
oApp.Application.Quit
Set oApp = Nothing
Application.DisplayAlerts = True
MsgBox "Reports Generated successfully!!!", vbInformation
End Sub
Sub browse_Click()
Dim dlgPickFiles As Office.FileDialog
Dim strList As String
Set dlgPickFiles = Application.FileDialog(msoFileDialogFolderPicker)
With dlgPickFiles
.AllowMultiSelect = False
With .Filters
.Clear
End With
.Show
'Me.Range("C5") = .SelectedItems(1)
On Error Resume Next
ActiveCell.Value = .SelectedItems(1)
'Range("C5") = .SelectedItems(1)
End With
Set dlgPickFiles = Nothing
End Sub
....Any solutions that i can try here.....
