Hi all,
I have the following code in Excel 2003, which is not working in Excel 2010, and I'm guessing that it's solely due to compatibility issues. I've been told the FileSearch code won't work above 2003, and to use the FileSystemObject or the Dir() function instead.
Can anyone spot some other VBA code that wont work with v.2010, or might the FileSearch be my only issue?
I GREATLY appreciate any help.
Thanks so much,
Ernie
-------------------------------------------------------------------------
Sub consolidateVF()
Dim sheettag(10) As String, wbsourcefolder As String, wbsourcefile As String, startcol As Integer
Dim wbsource As Workbook, monthrow As Integer, LastRowDestination As Integer, numbersRng As String
Dim rowcnt As Integer, programname As String, montcol As Integer, totalcol As Integer
Dim filecol As Integer, tagcolname As String, tagname As String, temprange As Range
Dim admincol As Integer, mktcol As Integer, implcol As Integer, DIcol As Integer, inccol As Integer
Dim Keycol1 As Integer, keycol2 As Integer, Keycol3 As Integer, programrng As Range
Dim progcol As Integer, progidcol As Integer, explgdcol As Integer, totalrng As Range
Dim kwrng As Range, kwhrng As Range, thmrng As Range, totalfiles As Long
Dim accrualfile As String, accrualwb As Workbook, accrualsht As Worksheet, accrualcol As Integer
Dim accrualtab As String, accrualfilefound As Boolean, implementer As String, Keycol4 As Integer
Dim accAdmin As Long, accMkt As Long, accImpl As Long, accInct As Long, accDI As Long, accrualcol2 As Integer
Dim forecastMth As String, Keycol5 As Integer, clearrng As Range, confirmMth As String
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
sheettag(0) = "Admin"
sheettag(1) = "Marketing"
sheettag(2) = "Implementation"
sheettag(3) = "Direct Install"
sheettag(4) = "Incentives"
sheettag(5) = "MW"
sheettag(6) = "GWH"
sheettag(7) = "MM Thms"
sheettag(8) = ""
sheettag(9) = ""
montcol = 19
totalcol = 20
admincol = 11
mktcol = 12
implcol = 13
DIcol = 14
inccol = 15
Keycol1 = 21
keycol2 = 22
Keycol3 = 23
Keycol4 = 24
Keycol5 = 25
progcol = 1
progidcol = 9
filecol = 3
startcol = 10
accrualcol = 2
accrualcol2 = 8
numbersRng = "K:R"
explgdcol = 10
tagcolname = "A"
cleanUpErrorTab
forecastMth = ThisWorkbook.Sheets("Setup").Cells(13, 2)
wbsourcefolder = ThisWorkbook.Sheets("Setup").Cells(14, 2)
accrualfile = ThisWorkbook.Sheets("Setup").Cells(15, 2)
accrualtab = ThisWorkbook.Sheets("Setup").Cells(15, 3)
ThisWorkbook.Sheets("Setup").Range("C16:D55") = ""
Set programrng = ThisWorkbook.Sheets("ConsolidatedData").Range("U:U")
Set totalrng = ThisWorkbook.Sheets("ConsolidatedData").Range("T:T")
Set kwrng = ThisWorkbook.Sheets("ConsolidatedData").Range("P:P")
Set kwhrng = ThisWorkbook.Sheets("ConsolidatedData").Range("Q:Q")
Set thmrng = ThisWorkbook.Sheets("ConsolidatedData").Range("R:R")
ThisWorkbook.Sheets("Setup").Activate
If MsgBox("Are you sure that the Forecast Month and Source Folder correct?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
With ThisWorkbook.Sheets("ConsolidatedData")
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
LastRowDestination = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
If .FilterMode Then
.ShowAllData
End If
.Range("A2:Z" & LastRowDestination).AutoFilter field:=24, Criteria1:=WorksheetFunction.Text(forecastMth, "mmm")
On Error Resume Next
Set clearrng = .Range("A2:Z" & LastRowDestination).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not clearrng Is Nothing Then clearrng.Clear
If .FilterMode Then .ShowAllData
.Range("A2:Z" & LastRowDestination).Sort Key1:=.Range("Y1")
'.Range("A2:Z" & LastRowDestination) = ""
End With
If Dir(accrualfile) <> "" Then
Set accrualwb = Workbooks.Open(accrualfile)
Set accrualsht = accrualwb.Sheets(accrualtab)
accrualsht.Protect Password:="3p", UserInterFaceOnly:=True
accrualfilefound = True
'Application.Run "'" & accrualfile & "'" & "!Delete"
Else
accrualfilefound = False
errortab = populateErrorTab(wbsourcefile, "Accrual", "Accrual File Not Found")
End If
With Application.FileSearch
.NewSearch
.LookIn = wbsourcefolder
.FileType = msoFileTypeExcelWorkbooks
.filename = "*.xls*"
If .Execute > 0 Then
totalfiles = .FoundFiles.Count
For lcount = 1 To totalfiles 'Loop through all.
wbsourcefile = .FoundFiles(lcount)
With ThisWorkbook.Sheets("ConsolidatedData")
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
LastRowDestination = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
End With
Set wbsource = Workbooks.Open(wbsourcefile)
wbsourcefile = Mid(wbsourcefile, InStrRev(wbsourcefile, "\") + 1)
ThisWorkbook.Sheets("Setup").Cells(lcount + 15, 3) = wbsourcefile
ThisWorkbook.Sheets("Setup").Cells(lcount + 15, 4) = "Error"
wbsource.Activate
tagcolname = "A"
tagname = Mid(wbsource.Sheets("Template").Cells(1, 1), 1, 20)
If tagname = "Forecasts & Accrual" Or tagname = "Forecast & Accrual -" Or Range("A1").Formula = "=""Forecasts and Accrual for "" & TEXT(C5,""mmmm yyyy"") & "" - "" & C6" Then
tagcolname = "B"
tagname = "Implementer & Program Name"
If IsError(Application.Match(tagname, wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)) = False Then
a = WorksheetFunction.Match(tagname, wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)
'programname = wbsource.Sheets("Template").Cells(a, 2) & wbsource.Sheets("Template").Cells(a, 3)
programname = wbsource.Sheets("Template").Cells(a, 3)
tagcolname = "A"
tagname = "Admin"
If IsError(Application.Match(tagname, wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)) = False Then
monthrow = WorksheetFunction.Match(tagname, wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0) - 1
Else
errortab = populateErrorTab(wbsourcefile, tagname, "Admin Tag Found. ")
End If
For j = 1 To 8
If IsError(Application.Match(sheettag(j - 1), wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)) = False Then
datarow = WorksheetFunction.Match(sheettag(j - 1), wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)
rowcnt = LastRowDestination
For k = 2 To 13
temp = wbsource.Sheets("Template").Cells(datarow, k)
If IsNumeric(temp) = False Then temp = 0
temp1 = wbsource.Sheets("Template").Cells(monthrow, k)
If CStr(temp1) <> "" Then
ThisWorkbook.Sheets("ConsolidatedData").Cells(rowcnt, j + startcol) = Trim(temp)
ThisWorkbook.Sheets("ConsolidatedData").Cells(rowcnt, montcol) = WorksheetFunction.Text(temp1, "MMM")
rowcnt = rowcnt + 1
End If
If WorksheetFunction.Text(temp1, "MMM") = "Jan" Then
'rowcnt = rowcnt + 1
Exit For
End If
Next
Else
If sheettag(j - 1) <> "Direct Install" Then
errortab = populateErrorTab(wbsourcefile, sheettag(j - 1), "No Such Tag Found")
End If
End If
Next
ThisWorkbook.Sheets("ConsolidatedData").Range("A" & LastRowDestination & ":A" & rowcnt - 1) = programname
Set temprange = ThisWorkbook.Sheets("Program Master Summary").Range("A:A")
datarow = 0
If IsError(Application.Match(programname, temprange, 0)) = False Then
datarow = WorksheetFunction.Match(programname, temprange, 0)
implementer = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 1)
ThisWorkbook.Sheets("ConsolidatedData").Range("B" & LastRowDestination & ":B" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 2)
ThisWorkbook.Sheets("ConsolidatedData").Range("C" & LastRowDestination & ":C" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 7)
ThisWorkbook.Sheets("ConsolidatedData").Range("D" & LastRowDestination & ":D" & rowcnt - 1) = ""
ThisWorkbook.Sheets("ConsolidatedData").Range("E" & LastRowDestination & ":E" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 11)
ThisWorkbook.Sheets("ConsolidatedData").Range("F" & LastRowDestination & ":F" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 12)
ThisWorkbook.Sheets("ConsolidatedData").Range("G" & LastRowDestination & ":G" & rowcnt - 1) = ""
ThisWorkbook.Sheets("ConsolidatedData").Range("H" & LastRowDestination & ":H" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 11)
ThisWorkbook.Sheets("ConsolidatedData").Range("I" & LastRowDestination & ":I" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 5)
ThisWorkbook.Sheets("ConsolidatedData").Range("J" & LastRowDestination & ":J" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 52)
ThisWorkbook.Sheets("ConsolidatedData").Range(numbersRng).NumberFormat = "0.00"
Else
errortab = populateErrorTab(wbsourcefile, programname, "Legends not found for this program")
End If
With ThisWorkbook.Sheets("ConsolidatedData")
For a = LastRowDestination To rowcnt - 1
.Cells(a, totalcol) = .Cells(a, admincol) + .Cells(a, mktcol) + .Cells(a, implcol) + .Cells(a, DIcol) + .Cells(a, inccol)
.Cells(a, Keycol1) = WorksheetFunction.Text(forecastMth, "mmm") & .Cells(a, progcol) & .Cells(a, montcol)
.Cells(a, keycol2) = WorksheetFunction.Text(forecastMth, "mmm") & .Cells(a, progidcol) & .Cells(a, montcol)
.Cells(a, Keycol3) = WorksheetFunction.Text(forecastMth, "mmm") & .Cells(a, explgdcol) & .Cells(a, montcol)
.Cells(a, Keycol4) = WorksheetFunction.Text(forecastMth, "mmm")
.Cells(a, Keycol5) = Month(forecastMth)
.Cells(a, Keycol5 + 1) = wbsourcefile
Next
End With
With ThisWorkbook.Sheets("ConsolidatedData")
If programname <> "" Then
temptotal = WorksheetFunction.SumIf(programrng, WorksheetFunction.Text(forecastMth, "mmm") & programname & "*", totalrng)
If temptotal = 0 Then
errortab = populateErrorTab(wbsourcefile, programname, "Program Budget totals are zero.")
End If
temptotal = WorksheetFunction.SumIf(programrng, WorksheetFunction.Text(forecastMth, "mmm") & programname & "*", kwrng) + WorksheetFunction.SumIf(programrng, WorksheetFunction.Text(forecastMth, "mmm") & programname & "*", kwhrng) + WorksheetFunction.SumIf(programrng, WorksheetFunction.Text(forecastMth, "mmm") & programname & "*", thmrng)
If temptotal = 0 Then
errortab = populateErrorTab(wbsourcefile, programname, "Program Savings totals are zero.")
End If
Else
errortab = populateErrorTab(wbsourcefile, programname, "Program Not found. Cannot verify the totals.")
End If
End With
ThisWorkbook.Sheets("Setup").Cells(lcount + 15, 3) = wbsourcefile
ThisWorkbook.Sheets("Setup").Cells(lcount + 15, 4) = "OK"
tagname = "Accrual"
If IsError(Application.Match(tagname, wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)) = False Then
accrualrow = WorksheetFunction.Match(tagname, wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)
Else
errortab = populateErrorTab(wbsourcefile, tagname, "Accrual Tag Found. ")
End If
accAdmin = wbsource.Sheets("Template").Cells(accrualrow + 4, accrualcol)
accMkt = wbsource.Sheets("Template").Cells(accrualrow + 5, accrualcol)
accImplt = wbsource.Sheets("Template").Cells(accrualrow + 6, accrualcol)
accInct = wbsource.Sheets("Template").Cells(accrualrow + 7, accrualcol)
accDI = wbsource.Sheets("Template").Cells(accrualrow + 8, accrualcol)
'wbsource.Close
accrualsht.Activate
tagcolname = "B"
If IsError(Application.Match(programname, accrualsht.Range(tagcolname & ":" & tagcolname), 0)) = False Then
accrualrow = WorksheetFunction.Match(programname, accrualsht.Range(tagcolname & ":" & tagcolname), 0)
accrualsht.Cells(accrualrow, accrualcol2) = accAdmin
accrualsht.Cells(accrualrow + 1, accrualcol2) = accMkt
accrualsht.Cells(accrualrow + 2, accrualcol2) = accImplt
accrualsht.Cells(accrualrow + 3, accrualcol2) = accInct
accrualsht.Cells(accrualrow + 4, accrualcol2) = accDI
Else
errortab = populateErrorTab(wbsourcefile, programname, "Program Not Found In FMT Journal Entry Template.")
End If
Else
errortab = populateErrorTab(wbsourcefile, tagname, "Program Name Tag Found")
End If
Else
errortab = populateErrorTab(wbsourcefile, tagname, "Invalid File. Not a forecast template.")
End If
wbsource.Close
Next
If totalfiles > 0 Then
ThisWorkbook.Sheets("Setup").Cells(lcount + 16, 3) = " Total of " & totalfiles & " files Processed."
Else
errortab = populateErrorTab(wbsourcefile, tagname, "No Files Found.")
End If
End If
End With
With ThisWorkbook.Sheets("DataError")
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End If
If lastRow > 1 Then
MsgBox ("Data Errors Found")
.Activate
Else
MsgBox ("Template Consolidation Complete.")
End If
End With
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub cleanUpErrorTab()
Dim lastRow As Integer
With ThisWorkbook.Sheets("DataError")
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
.Range("A2:" & "E" & lastRow) = ""
'End If
End With
End Sub
Function populateErrorTab(filename As String, tagname As String, ErrorDesc As String)
Dim lastRow As Integer
With ThisWorkbook.Sheets("DataError")
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
.Cells(lastRow, 1) = filename
.Cells(lastRow, 2) = tagname
.Cells(lastRow, 3) = ErrorDesc
End With
End Function
Sub PivotShowSpecificItems()
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim strPromptPF As String
Dim strPromptPI As String
Dim strPF As String
Dim strPI As String
ThisWorkbook.Sheets("PivotReport").Activate
Set pt = ActiveSheet.PivotTables(1)
strPF = "Data"
strPI = Range("FieldListSel")
Set pf = pt.PivotFields(strPF)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
pt.PivotFields("Month").Position = 1
For Each pi In pf.PivotItems
pi.Visible = False
Next pi
With pt.PivotFields("MW1")
.Orientation = xlDataField
.Function = xlSum
.Name = "MW"
.Position = 1
.NumberFormat = "#,##0"
End With
'ThisWorkbook.Sheets("PivotReport").PivotTables(1).PivotFields("Data").CurrentPage = strPI
On Error Resume Next
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub CleanupDataSheet()
With ThisWorkbook.Sheets("ConsolidatedData")
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
LastRowDestination = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
If .FilterMode Then .ShowAllData
.Range("A2:Z" & LastRowDestination) = ""
End With
End Sub
Sub extractExpenseActuals()
Dim idbsheet As Worksheet, idbfile As String, idbfolder As String, wb As Workbook, keycol2 As Integer
Dim idbforecastMthYr As String, idbforecastYr As String, CopyFromRangeCL As String
Dim forecastMth As Integer, forecastYr As Integer, forecastMthYr As Long, lastRowForecast As Integer
Dim sfolderrow As Integer, sfoldercol As Integer, lastRow As Long, forecastmthrow As Integer, forecastmthcol As Integer
Dim shareptfile As Boolean, checkedout As Boolean, tempdt As Date, tempval As String, j As Integer
Dim idbtab(2) As String, targettab As String, idbcriteriaField(2) As Integer, colno As Integer
Dim programcol(2) As Integer, monthcol(2) As Integer, keycol As Integer, mmtmcol(2) As Integer
'cleanUpErrorTab
sfoldercol = 2
sfolderrow = 3
forecastmthrow = 13
forecastmthcol = 2
checkedout = False
shareptfile = False
keycol = 9
keycol2 = 10
targettab = "Expense-Actuals"
Application.Calculation = xlCalculationAutomatic
cleanUpErrorTab
idbfolder = ThisWorkbook.Sheets("Setup").Cells(sfolderrow, sfoldercol)
idbforecastYr = Year(ThisWorkbook.Sheets("Setup").Cells(forecastmthrow, forecastmthcol))
idbforecastMthYr = CLng(Month(ThisWorkbook.Sheets("Setup").Cells(forecastmthrow, forecastmthcol)) & idbforecastYr)
If InStr(idbfolder, "http:") Or InStr(idbfolder, "https:") Then
shareptfile = True
idbfolderhttp = idbfolder
End If
fileexists = False
If InStr(idbfolder, "http:") Or InStr(idbfolder, "https:") Then
fileexists = True
Else
If Dir(idbfolder & idbfile) <> "" Then
fileexists = True
End If
End If
If fileexists Then
If shareptfile Then
Set wb = Workbooks.Open(idbfolderhttp & idbfile)
Else
Set wb = Workbooks.Open(idbfolder & idbfile)
End If
For i = 1 To wb.Sheets.Count
a = InStr(1, wb.Sheets(i).Name, "YTD", vbTextCompare)
If InStr(1, wb.Sheets(i).Name, "YTD", vbTextCompare) > 0 Then
With ThisWorkbook.Sheets(targettab)
If .FilterMode Then .ShowAllData
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
lastcol = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Column
End If
If lastRow > 0 Then
.Range("A2:Z" & lastRow) = ""
End If
End With
Set idbsheet = wb.Sheets(i)
If idbsheet.FilterMode Then
idbsheet.ShowAllData
End If
With idbsheet
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
For j = 1 To 8
tempval = ThisWorkbook.Sheets(targettab).Cells(1, j)
If IsError(.UsedRange.Find(What:=tempval, lookat:=xlWhole).Column) = False Then
colno = .UsedRange.Find(What:=tempval).Column
CopyFromRangeCL = ColLetter(colno) & 2 & ":" & ColLetter(colno) & lastRow
CopyToRangeCL = ColLetter(j) & 2 & ":" & ColLetter(j) & lastRow
Else
End If
ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL) = idbsheet.Range(CopyFromRangeCL).Value
Next
CopyFromRangeCL = ColLetter(keycol2) & 1
CopyToRangeCL = ColLetter(keycol2) & 2 & ":" & ColLetter(keycol2) & lastRow
ThisWorkbook.Sheets(targettab).Range(CopyFromRangeCL).Copy Destination:=ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL)
ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL).Value = ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL).Value
CopyFromRangeCL = ColLetter(keycol) & 1
CopyToRangeCL = ColLetter(keycol) & 2 & ":" & ColLetter(keycol) & lastRow
ThisWorkbook.Sheets(targettab).Range(CopyFromRangeCL).Copy Destination:=ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL)
ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL).Value = ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL).Value
End With
Exit For
End If
Next
wb.Close SaveChanges:=False
Else
'errortab = populateErrorTab("Setup", 0, "", "Data Setup Error: Dashboard File or Tab Name missing.")
End If
'Application.Calculation = xlManual
End Sub
Function ColLetter(ColNumber As Integer) As String
ColLetter = Left(Cells(1, ColNumber).Address(False, False), _
1 - (ColNumber > 26))
End Function
Sub extractActualsFromIDB()
Dim idbsheet As Worksheet, idbfile As String, idbfolder As String
Dim idbforecastMthYr As String, idbforecastYr As String, CopyFromRangeCL As String
Dim forecastMth As Integer, forecastYr As Integer, forecastMthYr As Long, lastRowForecast As Integer
Dim sfolderrow As Integer, sfoldercol As Integer, lastRow As Integer, forecastmthrow As Integer, forecastmthcol As Integer
Dim shareptfile As Boolean, checkedout As Boolean, tempdt As Date, tempval As String
Dim idbtab(2) As String, targettab(2) As String, idbcriteriaField(2) As Integer
Dim programcol(2) As Integer, monthcol(2) As Integer, keycol As Integer, datatypecol(2) As Integer
Dim trngdata As Range
sfoldercol = 2
sfolderrow = 7
forecastmthrow = 13
forecastmthcol = 2
checkedout = False
shareptfile = False
keycol = 28
idbtab(0) = "Actuals"
idbtab(1) = "Expense"
targettab(0) = "Savings-Actuals"
targettab(1) = "Expense-Actuals"
idbcriteriaField(0) = 14
idbcriteriaField(1) = 1
programcol(0) = 2
programcol(1) = 5
monthcol(0) = 19
monthcol(1) = 14
datatypecol(0) = 27
datatypecol(1) = 26
Application.Calculation = xlCalculationAutomatic
'cleanUpErrorTab
idbfolder = ThisWorkbook.Sheets("Setup").Cells(sfolderrow, sfoldercol)
idbforecastYr = Year(ThisWorkbook.Sheets("Setup").Cells(forecastmthrow, forecastmthcol))
idbforecastMthYr = CLng(Month(ThisWorkbook.Sheets("Setup").Cells(forecastmthrow, forecastmthcol)) & idbforecastYr)
idbtab(0) = ThisWorkbook.Sheets("Setup").Cells(sfolderrow, 3)
If InStr(idbfolder, "http:") Or InStr(idbfolder, "https:") Then
shareptfile = True
idbfolderhttp = idbfolder
End If
fileexists = False
If InStr(idbfolder, "http:") Or InStr(idbfolder, "https:") Then
fileexists = True
Else
If Dir(idbfolder & idbfile) <> "" Then
fileexists = True
End If
End If
If fileexists Then
If shareptfile Then
Set wb = Workbooks.Open(idbfolderhttp & idbfile)
Else
Set wb = Workbooks.Open(idbfolder & idbfile)
End If
For i = 1 To 1
With ThisWorkbook.Sheets(targettab(i - 1))
If .FilterMode Then .ShowAllData
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
If lastRow > 0 Then
.Range("A2:Z" & lastRow) = ""
End If
End With
Set idbsheet = wb.Sheets(idbtab(i - 1))
idbsheet.Visible = xlSheetVisible
idbsheet.Activate
If idbsheet.FilterMode Then
idbsheet.ShowAllData
End If
With idbsheet
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
CopyFromRangeCL = "A1:Z" & lastRow
End With
'idbsheet.Range(CopyFromRangeCL).AutoFilter field:=idbcriteriaField(i - 1), Criteria1:="3P"
'idbsheet.Range(CopyFromRangeCL).SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Sheets(targettab(i - 1)).Cells(1, 1)
idbsheet.Range(CopyFromRangeCL).Copy Destination:=ThisWorkbook.Sheets(targettab(i - 1)).Cells(1, 1)
Next
wb.Close SaveChanges:=False
Else
'errortab = populateErrorTab("Setup", 0, "", "Data Setup Error: Dashboard File or Tab Name missing.")
End If
For i = 1 To 1
With ThisWorkbook.Sheets(targettab(i - 1))
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End If
CopyFromRangeCL = ColLetter(keycol) & 1
CopyToRangeCL = ColLetter(keycol) & 2 & ":" & ColLetter(keycol) & lastRow
.Range(CopyFromRangeCL).Copy Destination:=.Range(CopyToRangeCL)
.Range(CopyToRangeCL).Value = .Range(CopyToRangeCL).Value
' Set trngdata = ThisWorkbook.Sheets("Program Master Summary").Range("E3:BA60")
' For j = 2 To lastRow
' tempval = ""
' If IsError(.Cells(j, programcol(i - 1))) = False Then
' tempval = .Cells(j, programcol(i - 1))
' End If
' .Cells(j, keycol) = tempval & MonthName(Mid(.Cells(j, monthcol(i - 1)), 5, 2), True)
' Next
End With
Next
End Sub
I have the following code in Excel 2003, which is not working in Excel 2010, and I'm guessing that it's solely due to compatibility issues. I've been told the FileSearch code won't work above 2003, and to use the FileSystemObject or the Dir() function instead.
Can anyone spot some other VBA code that wont work with v.2010, or might the FileSearch be my only issue?
I GREATLY appreciate any help.
Thanks so much,
Ernie
-------------------------------------------------------------------------
Sub consolidateVF()
Dim sheettag(10) As String, wbsourcefolder As String, wbsourcefile As String, startcol As Integer
Dim wbsource As Workbook, monthrow As Integer, LastRowDestination As Integer, numbersRng As String
Dim rowcnt As Integer, programname As String, montcol As Integer, totalcol As Integer
Dim filecol As Integer, tagcolname As String, tagname As String, temprange As Range
Dim admincol As Integer, mktcol As Integer, implcol As Integer, DIcol As Integer, inccol As Integer
Dim Keycol1 As Integer, keycol2 As Integer, Keycol3 As Integer, programrng As Range
Dim progcol As Integer, progidcol As Integer, explgdcol As Integer, totalrng As Range
Dim kwrng As Range, kwhrng As Range, thmrng As Range, totalfiles As Long
Dim accrualfile As String, accrualwb As Workbook, accrualsht As Worksheet, accrualcol As Integer
Dim accrualtab As String, accrualfilefound As Boolean, implementer As String, Keycol4 As Integer
Dim accAdmin As Long, accMkt As Long, accImpl As Long, accInct As Long, accDI As Long, accrualcol2 As Integer
Dim forecastMth As String, Keycol5 As Integer, clearrng As Range, confirmMth As String
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
sheettag(0) = "Admin"
sheettag(1) = "Marketing"
sheettag(2) = "Implementation"
sheettag(3) = "Direct Install"
sheettag(4) = "Incentives"
sheettag(5) = "MW"
sheettag(6) = "GWH"
sheettag(7) = "MM Thms"
sheettag(8) = ""
sheettag(9) = ""
montcol = 19
totalcol = 20
admincol = 11
mktcol = 12
implcol = 13
DIcol = 14
inccol = 15
Keycol1 = 21
keycol2 = 22
Keycol3 = 23
Keycol4 = 24
Keycol5 = 25
progcol = 1
progidcol = 9
filecol = 3
startcol = 10
accrualcol = 2
accrualcol2 = 8
numbersRng = "K:R"
explgdcol = 10
tagcolname = "A"
cleanUpErrorTab
forecastMth = ThisWorkbook.Sheets("Setup").Cells(13, 2)
wbsourcefolder = ThisWorkbook.Sheets("Setup").Cells(14, 2)
accrualfile = ThisWorkbook.Sheets("Setup").Cells(15, 2)
accrualtab = ThisWorkbook.Sheets("Setup").Cells(15, 3)
ThisWorkbook.Sheets("Setup").Range("C16:D55") = ""
Set programrng = ThisWorkbook.Sheets("ConsolidatedData").Range("U:U")
Set totalrng = ThisWorkbook.Sheets("ConsolidatedData").Range("T:T")
Set kwrng = ThisWorkbook.Sheets("ConsolidatedData").Range("P:P")
Set kwhrng = ThisWorkbook.Sheets("ConsolidatedData").Range("Q:Q")
Set thmrng = ThisWorkbook.Sheets("ConsolidatedData").Range("R:R")
ThisWorkbook.Sheets("Setup").Activate
If MsgBox("Are you sure that the Forecast Month and Source Folder correct?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
With ThisWorkbook.Sheets("ConsolidatedData")
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
LastRowDestination = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
If .FilterMode Then
.ShowAllData
End If
.Range("A2:Z" & LastRowDestination).AutoFilter field:=24, Criteria1:=WorksheetFunction.Text(forecastMth, "mmm")
On Error Resume Next
Set clearrng = .Range("A2:Z" & LastRowDestination).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not clearrng Is Nothing Then clearrng.Clear
If .FilterMode Then .ShowAllData
.Range("A2:Z" & LastRowDestination).Sort Key1:=.Range("Y1")
'.Range("A2:Z" & LastRowDestination) = ""
End With
If Dir(accrualfile) <> "" Then
Set accrualwb = Workbooks.Open(accrualfile)
Set accrualsht = accrualwb.Sheets(accrualtab)
accrualsht.Protect Password:="3p", UserInterFaceOnly:=True
accrualfilefound = True
'Application.Run "'" & accrualfile & "'" & "!Delete"
Else
accrualfilefound = False
errortab = populateErrorTab(wbsourcefile, "Accrual", "Accrual File Not Found")
End If
With Application.FileSearch
.NewSearch
.LookIn = wbsourcefolder
.FileType = msoFileTypeExcelWorkbooks
.filename = "*.xls*"
If .Execute > 0 Then
totalfiles = .FoundFiles.Count
For lcount = 1 To totalfiles 'Loop through all.
wbsourcefile = .FoundFiles(lcount)
With ThisWorkbook.Sheets("ConsolidatedData")
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
LastRowDestination = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
End With
Set wbsource = Workbooks.Open(wbsourcefile)
wbsourcefile = Mid(wbsourcefile, InStrRev(wbsourcefile, "\") + 1)
ThisWorkbook.Sheets("Setup").Cells(lcount + 15, 3) = wbsourcefile
ThisWorkbook.Sheets("Setup").Cells(lcount + 15, 4) = "Error"
wbsource.Activate
tagcolname = "A"
tagname = Mid(wbsource.Sheets("Template").Cells(1, 1), 1, 20)
If tagname = "Forecasts & Accrual" Or tagname = "Forecast & Accrual -" Or Range("A1").Formula = "=""Forecasts and Accrual for "" & TEXT(C5,""mmmm yyyy"") & "" - "" & C6" Then
tagcolname = "B"
tagname = "Implementer & Program Name"
If IsError(Application.Match(tagname, wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)) = False Then
a = WorksheetFunction.Match(tagname, wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)
'programname = wbsource.Sheets("Template").Cells(a, 2) & wbsource.Sheets("Template").Cells(a, 3)
programname = wbsource.Sheets("Template").Cells(a, 3)
tagcolname = "A"
tagname = "Admin"
If IsError(Application.Match(tagname, wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)) = False Then
monthrow = WorksheetFunction.Match(tagname, wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0) - 1
Else
errortab = populateErrorTab(wbsourcefile, tagname, "Admin Tag Found. ")
End If
For j = 1 To 8
If IsError(Application.Match(sheettag(j - 1), wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)) = False Then
datarow = WorksheetFunction.Match(sheettag(j - 1), wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)
rowcnt = LastRowDestination
For k = 2 To 13
temp = wbsource.Sheets("Template").Cells(datarow, k)
If IsNumeric(temp) = False Then temp = 0
temp1 = wbsource.Sheets("Template").Cells(monthrow, k)
If CStr(temp1) <> "" Then
ThisWorkbook.Sheets("ConsolidatedData").Cells(rowcnt, j + startcol) = Trim(temp)
ThisWorkbook.Sheets("ConsolidatedData").Cells(rowcnt, montcol) = WorksheetFunction.Text(temp1, "MMM")
rowcnt = rowcnt + 1
End If
If WorksheetFunction.Text(temp1, "MMM") = "Jan" Then
'rowcnt = rowcnt + 1
Exit For
End If
Next
Else
If sheettag(j - 1) <> "Direct Install" Then
errortab = populateErrorTab(wbsourcefile, sheettag(j - 1), "No Such Tag Found")
End If
End If
Next
ThisWorkbook.Sheets("ConsolidatedData").Range("A" & LastRowDestination & ":A" & rowcnt - 1) = programname
Set temprange = ThisWorkbook.Sheets("Program Master Summary").Range("A:A")
datarow = 0
If IsError(Application.Match(programname, temprange, 0)) = False Then
datarow = WorksheetFunction.Match(programname, temprange, 0)
implementer = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 1)
ThisWorkbook.Sheets("ConsolidatedData").Range("B" & LastRowDestination & ":B" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 2)
ThisWorkbook.Sheets("ConsolidatedData").Range("C" & LastRowDestination & ":C" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 7)
ThisWorkbook.Sheets("ConsolidatedData").Range("D" & LastRowDestination & ":D" & rowcnt - 1) = ""
ThisWorkbook.Sheets("ConsolidatedData").Range("E" & LastRowDestination & ":E" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 11)
ThisWorkbook.Sheets("ConsolidatedData").Range("F" & LastRowDestination & ":F" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 12)
ThisWorkbook.Sheets("ConsolidatedData").Range("G" & LastRowDestination & ":G" & rowcnt - 1) = ""
ThisWorkbook.Sheets("ConsolidatedData").Range("H" & LastRowDestination & ":H" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 11)
ThisWorkbook.Sheets("ConsolidatedData").Range("I" & LastRowDestination & ":I" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 5)
ThisWorkbook.Sheets("ConsolidatedData").Range("J" & LastRowDestination & ":J" & rowcnt - 1) = ThisWorkbook.Sheets("Program Master Summary").Cells(datarow, 52)
ThisWorkbook.Sheets("ConsolidatedData").Range(numbersRng).NumberFormat = "0.00"
Else
errortab = populateErrorTab(wbsourcefile, programname, "Legends not found for this program")
End If
With ThisWorkbook.Sheets("ConsolidatedData")
For a = LastRowDestination To rowcnt - 1
.Cells(a, totalcol) = .Cells(a, admincol) + .Cells(a, mktcol) + .Cells(a, implcol) + .Cells(a, DIcol) + .Cells(a, inccol)
.Cells(a, Keycol1) = WorksheetFunction.Text(forecastMth, "mmm") & .Cells(a, progcol) & .Cells(a, montcol)
.Cells(a, keycol2) = WorksheetFunction.Text(forecastMth, "mmm") & .Cells(a, progidcol) & .Cells(a, montcol)
.Cells(a, Keycol3) = WorksheetFunction.Text(forecastMth, "mmm") & .Cells(a, explgdcol) & .Cells(a, montcol)
.Cells(a, Keycol4) = WorksheetFunction.Text(forecastMth, "mmm")
.Cells(a, Keycol5) = Month(forecastMth)
.Cells(a, Keycol5 + 1) = wbsourcefile
Next
End With
With ThisWorkbook.Sheets("ConsolidatedData")
If programname <> "" Then
temptotal = WorksheetFunction.SumIf(programrng, WorksheetFunction.Text(forecastMth, "mmm") & programname & "*", totalrng)
If temptotal = 0 Then
errortab = populateErrorTab(wbsourcefile, programname, "Program Budget totals are zero.")
End If
temptotal = WorksheetFunction.SumIf(programrng, WorksheetFunction.Text(forecastMth, "mmm") & programname & "*", kwrng) + WorksheetFunction.SumIf(programrng, WorksheetFunction.Text(forecastMth, "mmm") & programname & "*", kwhrng) + WorksheetFunction.SumIf(programrng, WorksheetFunction.Text(forecastMth, "mmm") & programname & "*", thmrng)
If temptotal = 0 Then
errortab = populateErrorTab(wbsourcefile, programname, "Program Savings totals are zero.")
End If
Else
errortab = populateErrorTab(wbsourcefile, programname, "Program Not found. Cannot verify the totals.")
End If
End With
ThisWorkbook.Sheets("Setup").Cells(lcount + 15, 3) = wbsourcefile
ThisWorkbook.Sheets("Setup").Cells(lcount + 15, 4) = "OK"
tagname = "Accrual"
If IsError(Application.Match(tagname, wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)) = False Then
accrualrow = WorksheetFunction.Match(tagname, wbsource.Sheets("Template").Range(tagcolname & ":" & tagcolname), 0)
Else
errortab = populateErrorTab(wbsourcefile, tagname, "Accrual Tag Found. ")
End If
accAdmin = wbsource.Sheets("Template").Cells(accrualrow + 4, accrualcol)
accMkt = wbsource.Sheets("Template").Cells(accrualrow + 5, accrualcol)
accImplt = wbsource.Sheets("Template").Cells(accrualrow + 6, accrualcol)
accInct = wbsource.Sheets("Template").Cells(accrualrow + 7, accrualcol)
accDI = wbsource.Sheets("Template").Cells(accrualrow + 8, accrualcol)
'wbsource.Close
accrualsht.Activate
tagcolname = "B"
If IsError(Application.Match(programname, accrualsht.Range(tagcolname & ":" & tagcolname), 0)) = False Then
accrualrow = WorksheetFunction.Match(programname, accrualsht.Range(tagcolname & ":" & tagcolname), 0)
accrualsht.Cells(accrualrow, accrualcol2) = accAdmin
accrualsht.Cells(accrualrow + 1, accrualcol2) = accMkt
accrualsht.Cells(accrualrow + 2, accrualcol2) = accImplt
accrualsht.Cells(accrualrow + 3, accrualcol2) = accInct
accrualsht.Cells(accrualrow + 4, accrualcol2) = accDI
Else
errortab = populateErrorTab(wbsourcefile, programname, "Program Not Found In FMT Journal Entry Template.")
End If
Else
errortab = populateErrorTab(wbsourcefile, tagname, "Program Name Tag Found")
End If
Else
errortab = populateErrorTab(wbsourcefile, tagname, "Invalid File. Not a forecast template.")
End If
wbsource.Close
Next
If totalfiles > 0 Then
ThisWorkbook.Sheets("Setup").Cells(lcount + 16, 3) = " Total of " & totalfiles & " files Processed."
Else
errortab = populateErrorTab(wbsourcefile, tagname, "No Files Found.")
End If
End If
End With
With ThisWorkbook.Sheets("DataError")
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End If
If lastRow > 1 Then
MsgBox ("Data Errors Found")
.Activate
Else
MsgBox ("Template Consolidation Complete.")
End If
End With
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub cleanUpErrorTab()
Dim lastRow As Integer
With ThisWorkbook.Sheets("DataError")
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
.Range("A2:" & "E" & lastRow) = ""
'End If
End With
End Sub
Function populateErrorTab(filename As String, tagname As String, ErrorDesc As String)
Dim lastRow As Integer
With ThisWorkbook.Sheets("DataError")
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
.Cells(lastRow, 1) = filename
.Cells(lastRow, 2) = tagname
.Cells(lastRow, 3) = ErrorDesc
End With
End Function
Sub PivotShowSpecificItems()
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim strPromptPF As String
Dim strPromptPI As String
Dim strPF As String
Dim strPI As String
ThisWorkbook.Sheets("PivotReport").Activate
Set pt = ActiveSheet.PivotTables(1)
strPF = "Data"
strPI = Range("FieldListSel")
Set pf = pt.PivotFields(strPF)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
pt.PivotFields("Month").Position = 1
For Each pi In pf.PivotItems
pi.Visible = False
Next pi
With pt.PivotFields("MW1")
.Orientation = xlDataField
.Function = xlSum
.Name = "MW"
.Position = 1
.NumberFormat = "#,##0"
End With
'ThisWorkbook.Sheets("PivotReport").PivotTables(1).PivotFields("Data").CurrentPage = strPI
On Error Resume Next
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub CleanupDataSheet()
With ThisWorkbook.Sheets("ConsolidatedData")
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
LastRowDestination = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
If .FilterMode Then .ShowAllData
.Range("A2:Z" & LastRowDestination) = ""
End With
End Sub
Sub extractExpenseActuals()
Dim idbsheet As Worksheet, idbfile As String, idbfolder As String, wb As Workbook, keycol2 As Integer
Dim idbforecastMthYr As String, idbforecastYr As String, CopyFromRangeCL As String
Dim forecastMth As Integer, forecastYr As Integer, forecastMthYr As Long, lastRowForecast As Integer
Dim sfolderrow As Integer, sfoldercol As Integer, lastRow As Long, forecastmthrow As Integer, forecastmthcol As Integer
Dim shareptfile As Boolean, checkedout As Boolean, tempdt As Date, tempval As String, j As Integer
Dim idbtab(2) As String, targettab As String, idbcriteriaField(2) As Integer, colno As Integer
Dim programcol(2) As Integer, monthcol(2) As Integer, keycol As Integer, mmtmcol(2) As Integer
'cleanUpErrorTab
sfoldercol = 2
sfolderrow = 3
forecastmthrow = 13
forecastmthcol = 2
checkedout = False
shareptfile = False
keycol = 9
keycol2 = 10
targettab = "Expense-Actuals"
Application.Calculation = xlCalculationAutomatic
cleanUpErrorTab
idbfolder = ThisWorkbook.Sheets("Setup").Cells(sfolderrow, sfoldercol)
idbforecastYr = Year(ThisWorkbook.Sheets("Setup").Cells(forecastmthrow, forecastmthcol))
idbforecastMthYr = CLng(Month(ThisWorkbook.Sheets("Setup").Cells(forecastmthrow, forecastmthcol)) & idbforecastYr)
If InStr(idbfolder, "http:") Or InStr(idbfolder, "https:") Then
shareptfile = True
idbfolderhttp = idbfolder
End If
fileexists = False
If InStr(idbfolder, "http:") Or InStr(idbfolder, "https:") Then
fileexists = True
Else
If Dir(idbfolder & idbfile) <> "" Then
fileexists = True
End If
End If
If fileexists Then
If shareptfile Then
Set wb = Workbooks.Open(idbfolderhttp & idbfile)
Else
Set wb = Workbooks.Open(idbfolder & idbfile)
End If
For i = 1 To wb.Sheets.Count
a = InStr(1, wb.Sheets(i).Name, "YTD", vbTextCompare)
If InStr(1, wb.Sheets(i).Name, "YTD", vbTextCompare) > 0 Then
With ThisWorkbook.Sheets(targettab)
If .FilterMode Then .ShowAllData
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
lastcol = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Column
End If
If lastRow > 0 Then
.Range("A2:Z" & lastRow) = ""
End If
End With
Set idbsheet = wb.Sheets(i)
If idbsheet.FilterMode Then
idbsheet.ShowAllData
End If
With idbsheet
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
For j = 1 To 8
tempval = ThisWorkbook.Sheets(targettab).Cells(1, j)
If IsError(.UsedRange.Find(What:=tempval, lookat:=xlWhole).Column) = False Then
colno = .UsedRange.Find(What:=tempval).Column
CopyFromRangeCL = ColLetter(colno) & 2 & ":" & ColLetter(colno) & lastRow
CopyToRangeCL = ColLetter(j) & 2 & ":" & ColLetter(j) & lastRow
Else
End If
ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL) = idbsheet.Range(CopyFromRangeCL).Value
Next
CopyFromRangeCL = ColLetter(keycol2) & 1
CopyToRangeCL = ColLetter(keycol2) & 2 & ":" & ColLetter(keycol2) & lastRow
ThisWorkbook.Sheets(targettab).Range(CopyFromRangeCL).Copy Destination:=ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL)
ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL).Value = ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL).Value
CopyFromRangeCL = ColLetter(keycol) & 1
CopyToRangeCL = ColLetter(keycol) & 2 & ":" & ColLetter(keycol) & lastRow
ThisWorkbook.Sheets(targettab).Range(CopyFromRangeCL).Copy Destination:=ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL)
ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL).Value = ThisWorkbook.Sheets(targettab).Range(CopyToRangeCL).Value
End With
Exit For
End If
Next
wb.Close SaveChanges:=False
Else
'errortab = populateErrorTab("Setup", 0, "", "Data Setup Error: Dashboard File or Tab Name missing.")
End If
'Application.Calculation = xlManual
End Sub
Function ColLetter(ColNumber As Integer) As String
ColLetter = Left(Cells(1, ColNumber).Address(False, False), _
1 - (ColNumber > 26))
End Function
Sub extractActualsFromIDB()
Dim idbsheet As Worksheet, idbfile As String, idbfolder As String
Dim idbforecastMthYr As String, idbforecastYr As String, CopyFromRangeCL As String
Dim forecastMth As Integer, forecastYr As Integer, forecastMthYr As Long, lastRowForecast As Integer
Dim sfolderrow As Integer, sfoldercol As Integer, lastRow As Integer, forecastmthrow As Integer, forecastmthcol As Integer
Dim shareptfile As Boolean, checkedout As Boolean, tempdt As Date, tempval As String
Dim idbtab(2) As String, targettab(2) As String, idbcriteriaField(2) As Integer
Dim programcol(2) As Integer, monthcol(2) As Integer, keycol As Integer, datatypecol(2) As Integer
Dim trngdata As Range
sfoldercol = 2
sfolderrow = 7
forecastmthrow = 13
forecastmthcol = 2
checkedout = False
shareptfile = False
keycol = 28
idbtab(0) = "Actuals"
idbtab(1) = "Expense"
targettab(0) = "Savings-Actuals"
targettab(1) = "Expense-Actuals"
idbcriteriaField(0) = 14
idbcriteriaField(1) = 1
programcol(0) = 2
programcol(1) = 5
monthcol(0) = 19
monthcol(1) = 14
datatypecol(0) = 27
datatypecol(1) = 26
Application.Calculation = xlCalculationAutomatic
'cleanUpErrorTab
idbfolder = ThisWorkbook.Sheets("Setup").Cells(sfolderrow, sfoldercol)
idbforecastYr = Year(ThisWorkbook.Sheets("Setup").Cells(forecastmthrow, forecastmthcol))
idbforecastMthYr = CLng(Month(ThisWorkbook.Sheets("Setup").Cells(forecastmthrow, forecastmthcol)) & idbforecastYr)
idbtab(0) = ThisWorkbook.Sheets("Setup").Cells(sfolderrow, 3)
If InStr(idbfolder, "http:") Or InStr(idbfolder, "https:") Then
shareptfile = True
idbfolderhttp = idbfolder
End If
fileexists = False
If InStr(idbfolder, "http:") Or InStr(idbfolder, "https:") Then
fileexists = True
Else
If Dir(idbfolder & idbfile) <> "" Then
fileexists = True
End If
End If
If fileexists Then
If shareptfile Then
Set wb = Workbooks.Open(idbfolderhttp & idbfile)
Else
Set wb = Workbooks.Open(idbfolder & idbfile)
End If
For i = 1 To 1
With ThisWorkbook.Sheets(targettab(i - 1))
If .FilterMode Then .ShowAllData
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
If lastRow > 0 Then
.Range("A2:Z" & lastRow) = ""
End If
End With
Set idbsheet = wb.Sheets(idbtab(i - 1))
idbsheet.Visible = xlSheetVisible
idbsheet.Activate
If idbsheet.FilterMode Then
idbsheet.ShowAllData
End If
With idbsheet
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
End If
CopyFromRangeCL = "A1:Z" & lastRow
End With
'idbsheet.Range(CopyFromRangeCL).AutoFilter field:=idbcriteriaField(i - 1), Criteria1:="3P"
'idbsheet.Range(CopyFromRangeCL).SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Sheets(targettab(i - 1)).Cells(1, 1)
idbsheet.Range(CopyFromRangeCL).Copy Destination:=ThisWorkbook.Sheets(targettab(i - 1)).Cells(1, 1)
Next
wb.Close SaveChanges:=False
Else
'errortab = populateErrorTab("Setup", 0, "", "Data Setup Error: Dashboard File or Tab Name missing.")
End If
For i = 1 To 1
With ThisWorkbook.Sheets(targettab(i - 1))
If WorksheetFunction.CountA(.UsedRange) > 0 Then
'Search for any entry, by searching backwards by Rows.
lastRow = .UsedRange.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End If
CopyFromRangeCL = ColLetter(keycol) & 1
CopyToRangeCL = ColLetter(keycol) & 2 & ":" & ColLetter(keycol) & lastRow
.Range(CopyFromRangeCL).Copy Destination:=.Range(CopyToRangeCL)
.Range(CopyToRangeCL).Value = .Range(CopyToRangeCL).Value
' Set trngdata = ThisWorkbook.Sheets("Program Master Summary").Range("E3:BA60")
' For j = 2 To lastRow
' tempval = ""
' If IsError(.Cells(j, programcol(i - 1))) = False Then
' tempval = .Cells(j, programcol(i - 1))
' End If
' .Cells(j, keycol) = tempval & MonthName(Mid(.Cells(j, monthcol(i - 1)), 5, 2), True)
' Next
End With
Next
End Sub
