Hello!
I am learning VBA language, and I've been doing pretty well
BUT I know when things are outside my comfort zone! A little background, this is a file for work that was created a long time ago, and was honestly not very good. I have been cleaning up the file and THOUGHT I was done, but the main macro in the workbook stopped working. I didn't change the macro, or put things in a different place, I just replaced things with formulas.
So basically, the point of the macro is that it prompts the user to select a folder, then the macro opens every excel file in the folder and pulls certain information from each of the excel files. The files it opens (recons) have certain summary information up top, each of the relevant cells is "Named" and that information needs to go onto a master file. Here are the "Names" on the recon files:
<tbody>
</tbody>
The code is quite lengthy, and quite a bit of it is devoted to a double progress bar (DoublePBar in the code), which has some weird stuff. Specifically, there's a hidden tab called Settings which I would love to get rid of because I don't think it's necessary, except that the DoublePBar uses it or PC1, PC2, PC2 (percent complete 1, 2 and 3) and Task 1, 2 and 3. The first thing I did was remove all progress bar code. Once I did this, the macro ran without any errors, however none of the information from the recons was actually pasted onto the master file.
I would love to attach the files, but I don't think I can? Any help would be appreciated!!
I am learning VBA language, and I've been doing pretty well
BUT I know when things are outside my comfort zone! A little background, this is a file for work that was created a long time ago, and was honestly not very good. I have been cleaning up the file and THOUGHT I was done, but the main macro in the workbook stopped working. I didn't change the macro, or put things in a different place, I just replaced things with formulas. So basically, the point of the macro is that it prompts the user to select a folder, then the macro opens every excel file in the folder and pulls certain information from each of the excel files. The files it opens (recons) have certain summary information up top, each of the relevant cells is "Named" and that information needs to go onto a master file. Here are the "Names" on the recon files:
| Name | Cell | Task on "Test File" |
| ACCT | E6 | Match to column A of master file |
| AgedD | M12 | Paste into corresponding ACCT Column K |
| AgedD0 | M5 | Paste into corresponding ACCT Column S |
| AgedD3 | M7 | Paste into corresponding ACCT Column U |
| AgedD6 | M9 | Paste into corresponding ACCT Column W |
| AgedI | M11 | Paste into corresponding ACCT Column L |
| AgedI0 | M6 | Paste into corresponding ACCT Column R |
| AgedI3 | M8 | Paste into corresponding ACCT Column T |
| AgedI6 | M10 | Paste into corresponding ACCT Column V |
| Comp | E4 | Matches "Entity" on Test File (named) |
| glbal | M14 | Paste into corresponding ACCT Column O |
| pby | K17 | Paste into corresponding ACCT Column D |
| Prepared | M17 | If not blank, YES in corresponding Column H |
| rby | K19 | Paste into corresponding ACCT Column E |
| Reviewed | M19 | If not blank, YES in corresponding Column I |
| risk | M15 | Paste into corresponding ACCT Column M |
<tbody>
</tbody>
The code is quite lengthy, and quite a bit of it is devoted to a double progress bar (DoublePBar in the code), which has some weird stuff. Specifically, there's a hidden tab called Settings which I would love to get rid of because I don't think it's necessary, except that the DoublePBar uses it or PC1, PC2, PC2 (percent complete 1, 2 and 3) and Task 1, 2 and 3. The first thing I did was remove all progress bar code. Once I did this, the macro ran without any errors, however none of the information from the recons was actually pasted onto the master file.
I would love to attach the files, but I don't think I can? Any help would be appreciated!!
Code:
'Oracle R12 Version
Public OracleFileName As String
Public ReportTitle As String
Public NewTabName As String
Public SkipThisFolder As Boolean
Public ExitItAll As Boolean
Public iFile As Integer
Public iFolder As Integer
Public FileCount As Integer
Public FolderCount As Integer
Public ReconAcct As String
Public ReconComp As String
Public isRec As String
Dim SegmentFileOpen As Balloon
Dim Counter As Integer ' Dummy variable for "For... i = 1 To n" loop
Dim HOME As Range ' Range C37; must be defined from the worksheet
Dim START As Range ' Range P18; must be defined from the workseet
Dim LastEntry As Range ' This the line item just above HOME
Dim BSCDate As Range ' The date on the BSControls Sheet
Dim BSCEntity As Range ' The Entity on the BSControls Sheet
Dim MyFormula As Range
Dim RangeStart As Range
Dim RangeFinish As Range
Dim acctrng As Range
Dim myRow ' Number of rows to be inserted
Dim OldValue
Dim myDate 'Date for this file
Dim Msg ' Variables for MsgBox
Dim CELL ' Dummy var for "For Each... Next..." loop
Dim Drive, Folder, StartFolder, SubFolder, File, FileList, S, T 'for file handling section
Dim FormSize As Single
Dim a As Object
Dim b As Object
Dim PC1 As Object
Dim PC2 As Object
Dim PC3 As Object
Dim Task1 As Object
Dim Task2 As Object
Dim Task3 As Object
Public PctDone As Single
Public Task As String
Dim SqrNum As Long
Dim Corner As Object
Public HP As String
Public Const Pass = "gokings"
Public Const Button = vbOKOnly + vbExclamation
Sub select_account()
ActiveSheet.Unprotect Password:=Pass
Application.ScreenUpdating = True
Set acctrng = ThisWorkbook.Worksheets(OldValue).Range(Range("A13"), Range("A13").End(xlDown))
'Set acctrng = ThisWorkbook.Worksheets("0004").Range(Range("A13"), Range("A13").End(xlDown))
For Each acct In acctrng
If acct.Offset(0, 5).Value = 0 Then
accSelector.acctnames.AddItem acct & " - " & acct.Offset(0, 1)
' accSelector.acctnamesReal.AddItem acct.Offset(0, 1)
End If
Next acct
accSelector.Width = 505
accSelector.Height = 540
accSelector.Show
Set acctrng = Nothing
Set acctrng = ThisWorkbook.Worksheets(OldValue).Range(Range("A13"), Range("A13").End(xlDown))
Set findrng = ThisWorkbook.Worksheets("Settings").Range(ThisWorkbook.Worksheets("Settings").Range("AA2"), _
ThisWorkbook.Worksheets("Settings").Range("AA2").End(xlDown))
'findrng.Select
ahashsh = findrng.Rows.Count
If findrng.Rows.Count = "1048575" Then
Set findrng = ThisWorkbook.Worksheets("Settings").Range("AA2")
End If
Load frmPBar
frmPBar.LabelProgress.Width = 0
frmPBar.Show False
flag = 0
Application.ScreenUpdating = False
For Each a In acctrng
zz = acctrng.Rows.Count
PctDone = (a.Row - 12) / acctrng.Rows.Count
If a.Offset(0, 5) <> 0 Then GoTo nextacct
For Each b In findrng
' MsgBox b
If InStr(b, a) > 0 Then
flag = 1
End If
Next b
If flag = 0 Then
a.EntireRow.Hidden = True
End If
flag = 0
nextacct:
With frmPBar
.Caption = "Looking selected accounts" 'update the caption on the frame
.FrameProgress.Caption = Format(PctDone, "0%") ' Update the Caption property of the Frame control.
.LabelProgress.Width = PctDone * .FrameProgress.Width ' Widen the Label control.
End With
DoEvents '
Next a
Unload frmPBar
Application.ScreenUpdating = True
ActiveSheet.Protect Password:=Pass
End Sub
Sub acctselector_Done()
ThisWorkbook.Worksheets("Settings").Range(ThisWorkbook.Worksheets("Settings").Range("AA2"), _
ThisWorkbook.Worksheets("Settings").Range("AA2").End(xlDown)).ClearContents
ThisWorkbook.Worksheets("Settings").Range(ThisWorkbook.Worksheets("Settings").Range("AB2"), _
ThisWorkbook.Worksheets("Settings").Range("AB2").End(xlDown)).ClearContents
ThisWorkbook.Worksheets("Settings").Range(ThisWorkbook.Worksheets("Settings").Range("AC2"), _
ThisWorkbook.Worksheets("Settings").Range("AC2").End(xlDown)).ClearContents
For i = 0 To accSelector.selectedAcct.ListCount - 1
ThisWorkbook.Worksheets("Settings").Range("AA" & i + 2).Value = accSelector.selectedAcct.List(i)
Next i
Unload accSelector
End Sub
Sub GetAgedInfo()
ThisWorkbook.Worksheets("Settings").Range("StartTime") = Now
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set BSCDate = ThisWorkbook.Worksheets("Settings").Range("ThisFileDate")
'Set BSCEntity = ActiveSheet.Range("Entity")
SkipThisFolder = False
ExitItAll = False
Set PC1 = ThisWorkbook.Worksheets("settings").Range("PC1")
Set Task1 = ThisWorkbook.Worksheets("settings").Range("Task1")
Set PC2 = ThisWorkbook.Worksheets("settings").Range("PC2")
Set Task2 = ThisWorkbook.Worksheets("settings").Range("Task2")
Set PC3 = ThisWorkbook.Worksheets("settings").Range("PC3")
Set Task3 = ThisWorkbook.Worksheets("settings").Range("Task3")
ThisWorkbook.ActiveSheet.Unprotect Password:=Pass
'let the user decide if using terminal server or desktop
Response = MsgBox("Are you using Terminal Server?", vbYesNo, Title)
If Response = vbNo Then
GoTo OpenFolderDialog 'if using terminal server, ask the user for the path
Else
GoTo AskUserForPath ' if not using TS, launch the file path finder window
End If
OpenFolderDialog:
' Let the user pick the folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = True
.Show
End With
'define the folder name
FolderName = Application.FileDialog(msoFileDialogFolderPicker).InitialFileName
'cycle thrtouh each file in the folder
If FolderName <> "" Then
GoTo KeepGoing
End If
AskUserForPath:
'If using Terminal Server, ask the user to specify the path to the folder
GetValue:
FolderName = InputBox("Enter the full path for the folder you want to process " & Chr(13) & Chr(13) & "(Including drive letter, ie: R:\Folder\Subfolder)", Title)
' Check 1
If FolderName = "" Then
GoTo CleanUp
End If
KeepGoing:
Load DoublePBar
With DoublePBar
.Progress1.Width = 0
.Progress2.Width = 0
.Progress3.Width = 0
.Show False
.Height = 120
End With
DoEvents
Set Drive = CreateObject("Scripting.FileSystemObject")
Set Folder = Drive.GetFolder(FolderName) 'set the folder
Set StartFolder = Folder ' set the original folder so we can get back to it later
FileCounter FileCount, FolderCount
SubFolderCount Folder, PC1, PC2, PC3, Task1, Task2, Task3, FolderCount, FileCount, iFile, iFolder 'test if there are any subfolders
Unload DoublePBar
DoEvents
Application.ScreenUpdating = True
Application.ScreenUpdating = False
Response = MsgBox("The wizard found " & FileCount & " files in " & FolderCount & " folders." & Chr(13) & Chr(13) _
& "It may take up to " & Format(FileCount * 1 / 60 / 60, "0.00") & " hours to prcess these files" & Chr(13) & Chr(13) _
& "Do you want to continue and process these files now?", vbYesNo, Title)
If Response = vbNo Then
GoTo CleanUp
End If
Set Folder = StartFolder 'go back to the original folder
Load DoublePBar
With DoublePBar
.Progress1.Width = 0
.Progress2.Width = 0
.Progress3.Width = 0
.CB1.Caption = " Skip Folder "
.CB2.Caption = "Save and Continue"
.CB3.Caption = "Stop and Save "
.Show False
.Height = 190
End With
DoEvents
iFolder = 1
PC1.Value = iFolder / FolderCount
Task1.Value = "Folder: " & Folder.Name
iFile = 1
iFolder = 1
FileAction Folder, PC1, PC2, PC3, Task1, Task2, Task3, FolderCount, FileCount, iFile, iFolder ' do all files in this folder
SubFolderTest Folder, PC1, PC2, PC3, Task1, Task2, Task3, FolderCount, FileCount, iFile, iFolder 'do the subfolders
CleanUp:
PC3.Value = 0
Task3.Value = "Tab: "
PC2.Value = 0.001
Task2.Value = "File: "
PC1.Value = 0
Task1.Value = "Folder: "
Unload DoublePBar
FileCount = 0
FolderCount = 0
iFile = 0
iFolder = 0
EndIt
ThisWorkbook.Worksheets("Settings").Range("EndTime") = Now
Calculate
End Sub
Function CountFilesAndFolders(Folder, PC1, PC2, PC3, Task1, Task2, Task3, FolderCount, FileCount)
For Each SubFolder In Folder.SubFolders
Set Folder = SubFolder
FileCounter FileCount, FolderCount
SubFolderCount Folder, PC1, PC2, PC3, Task1, Task2, Task3, FolderCount, FileCount, iFile, iFolder 'test if there are any subfolders
Next SubFolder
End Function
Function SubFolderCount(Folder, PC1, PC2, PC3, Task1, Task2, Task3, FolderCount, FileCount, iFile, iFolder)
If Folder.SubFolders.Count > 0 Then
CountFilesAndFolders Folder, PC1, PC2, PC3, Task1, Task2, Task3, FolderCount, FileCount
End If
End Function
Function FileCounter(FileCount, FolderCount)
FileCount = FileCount + Folder.FileS.Count 'add the files in this folder to the running file coun
FolderCount = FolderCount + 1 ' add this folder to the running folder count
'updated the progress bar
PC2.Value = FileCount * 0.0005
Task2.Value = "Files: " & FileCount
PC1.Value = FolderCount * 0.005
Task1.Value = "Folders: " & FolderCount
UpdateDoublePBar
End Function
Function FolderAction(Folder, PC1, PC2, PC3, Task1, Task2, Task3, FolderCount, FileCount, iFile, iFolder)
For Each SubFolder In Folder.SubFolders
If SkipThisFolder = True Then
SkipThisFolder = False
GoTo NextSubfolder
End If
If ExitItAll = True Then
Exit Function
End If
Set Folder = SubFolder
iFolder = iFolder + 1
'updated the progress bar
PC3.Value = 0
Task3.Value = "Tab: "
Task2.Value = "File: "
PC1.Value = iFolder / FolderCount
Task1.Value = "Folder: " & Folder.ParentFolder.ParentFolder.Name & "\" & Folder.ParentFolder.Name & "\" & Folder.Name
UpdateDoublePBar
FileAction Folder, PC1, PC2, PC3, Task1, Task2, Task3, FolderCount, FileCount, iFile, iFolder ' do all files in the folder
If SkipThisFolder = True Then
SkipThisFolder = False
GoTo NextSubfolder
End If
If ExitItAll = True Then
Exit Function
End If
SubFolderTest Folder, PC1, PC2, PC3, Task1, Task2, Task3, FolderCount, FileCount, iFile, iFolder 'test if there are any subfolders
NextSubfolder:
Next SubFolder
End Function
Function SubFolderTest(Folder, PC1, PC2, PC3, Task1, Task2, Task3, FolderCount, FileCount, iFile, iFolder)
If ExitItAll = True Then
Exit Function
End If
If Folder.SubFolders.Count > 0 Then
FolderAction Folder, PC1, PC2, PC3, Task1, Task2, Task3, FolderCount, FileCount, iFile, iFolder
End If
End Function
Function FileAction(Folder, PC1, PC2, PC3, Task1, Task2, Task3, FolderCount, FileCount, iFile, iFolder)
Application.ScreenUpdating = True
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.CalculateBeforeSave = False
Set FileList = Folder.FileS
For Each File In FileList
If SkipThisFolder = True Or ExitItAll = True Then
Exit Function
End If
PC2.Value = iFile / FileCount
Task2.Value = "File: " & File.Name
UpdateDoublePBar
If Right(File.Name, 3) = "xls" Or Right(File.Name, 3) = "XLS" Or _
Right(File.Name, 4) = "xlsx" Or Right(File.Name, 4) = "XLSX" Or _
Right(File.Name, 4) = "xlsm" Or Right(File.Name, 4) = "XLSM" Then ' check if this is an excel file
Else
GoTo NextFile
End If
OpenTheFile File, FileIsOpen 'open the file in a different function just incase there is an error caused by password protection
Application.StatusBar = False
If FileIsOpen = "No" Then
GoTo NextFile
End If
For Each S In Workbooks(File.Name).Worksheets
'updated the progress bar
'PC3.Value = S.Index / Workbooks(File.Name).Worksheets.Count
'Task3.Value = "Tab: " & S.Name
UpdateDoublePBar
If S.Name = "Settings" Then 'check if the file is a BSControls file. If it is, close it and move on
GoTo CloseIt
End If
If Workbooks(File.Name).Names.Count = 0 Then 'check if the file has named ranges, if not close it and move on
GoTo CloseIt
End If
FileIsRec:
isRec = "" 'set the the check to blank and run check if the sheet has the right named ranges in it.
CheckSheet File, S, isRec, ReconAcct, RangeStart
ThisWorkbook.Activate
If isRec = "NO" Then
GoTo NextS
End If
TabAction File, S, isRec ' if all condition are met, run the tab action to get the data from the rec file to this file
Range("A11").Select
NextS:
Next S
'close the file and go to the next file
CloseIt:
Workbooks(File.Name).Close savechanges:=False
NextFile:
PC3.Value = 0
iFile = iFile + 1
ThisWorkbook.Worksheets("Settings").Range("EndTime") = Now
'ThisWorkbook.Worksheets("Settings").Range("E16").Calculate
Next File
End Function
Function TabAction(File, S, isRec)
1:
On Error GoTo ErrorFound
Select Case isRec
Case "Yes" ' if the sheet is a valid rec, populate the data by coping the values from the rec to this file
RangeStart.Offset(0, 2).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("Timing").Value
RangeStart.Offset(0, 3).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("Pby").Value
RangeStart.Offset(0, 4).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("Rby").Value
RangeStart.Offset(0, 7).Value = "Yes"
RangeStart.Offset(0, 10).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedD").Value
RangeStart.Offset(0, 12).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedI").Value
RangeStart.Offset(0, 13).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("RISK").Value
'Workbooks(File.Name).Worksheets(s.Name).Activate
RangeStart.Offset(0, 14).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("Com").Value
RangeStart.Offset(0, 15).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("GLBal").Value
RangeStart.Offset(0, 19).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedI0").Value
RangeStart.Offset(0, 21).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedD0").Value
RangeStart.Offset(0, 22).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedI3").Value
RangeStart.Offset(0, 24).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedD3").Value
RangeStart.Offset(0, 25).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedI6").Value
RangeStart.Offset(0, 27).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedD6").Value
Case "No Match" 'no match was found. Add a blank row at the bottom and copy the values from the recon sheet
ThisWorkbook.ActiveSheet.Range("A13").End(xlDown).Offset(1, 0).EntireRow.Select
Selection.Copy
Selection.Offset(1, 0).Select
ActiveSheet.Paste
Cells(Selection.Row - 1, 1).Select
Selection.Value = ReconAcct
RangeStart.Offset(0, 2).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("Timing").Value
Selection.Offset(0, 3).Select
SelectionValue = Workbooks(File.Name).Worksheets(S.Name).Range("Pby").Value
RangeStart.Offset(0, 4).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("Rby").Value
Selection.Offset(0, 7).Value = "Yes"
Selection.Offset(0, 10).Select
SelectionValue = Workbooks(File.Name).Worksheets(S.Name).Range("AgedD").Value
Selection.Offset(0, 12).Select
SelectionValue = Workbooks(File.Name).Worksheets(S.Name).Range("AgedI").Value
Selection.Offset(0, 13).Select
SelectionValue = Workbooks(File.Name).Worksheets(S.Name).Range("RISK").Value
Selection.Offset(0, 14).Select
SelectionValue = Workbooks(File.Name).Worksheets(S.Name).Range("Com").Value
Selection.Offset(0, 15).Select
SelectionValue = Workbooks(File.Name).Worksheets(S.Name).Range("GLBal").Value
RangeStart.Offset(0, 21).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedI0").Value
RangeStart.Offset(0, 22).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedD0").Value
RangeStart.Offset(0, 24).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedI3").Value
RangeStart.Offset(0, 25).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedD3").Value
RangeStart.Offset(0, 27).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedI6").Value
RangeStart.Offset(0, 28).Select
Selection = Workbooks(File.Name).Worksheets(S.Name).Range("AgedD6").Value
Case Else
End Select
Exit Function
ErrorFound:
On Error GoTo 0
On Error Resume Next
' Selection = "***Error: The Wizard Could not find the Named Range in the recon file.***" 'put an error message in the cell of the missing range
On Error GoTo ErrorFound
Resume Next
End Function
Function OpenTheFile(File, FileIsOpen)
Application.StatusBar = "Opening " & File.Name
On Error GoTo FileIsNotOpen
Workbooks.Open Filename:=File, UpdateLinks:=False, ReadOnly:=True
Application.Calculation = xlCalculationManual
Application.CalculateBeforeSave = False
On Error GoTo 0
FileIsOpen = "Yes"
Exit Function
FileIsNotOpen:
FileIsOpen = "No"
End Function
Function CheckSheet(File, S, isRec, ReconAcct, RangeStart)
On Error GoTo NotARecSheet
For Each T In ThisWorkbook.Worksheets
If Workbooks(File.Name).Worksheets(S.Name).Range("COMP") = T.Name Then
ReconComp = T.Name
T.Activate
GoTo CompanyMatch
End If
Next T
GoTo NotARecSheet
CompanyMatch:
If Workbooks(File.Name).Worksheets(S.Name).Range("DATE") = BSCDate.Value Then
ReconAcct = Workbooks(File.Name).Worksheets(S.Name).Range("ACCT").Value 'Find the account and set it as the starting point for populating the data
On Error GoTo NoMatch
Set RangeStart = ThisWorkbook.Worksheets(ReconComp).Cells.Find(What:=ReconAcct) 'set the account on the matching company sheet on this file
If RangeStart = "" Then 'if the account was not found for the given company, skip the sheet.
GoTo NoMatch
End If
isRec = "Yes"
End If
Exit Function
NotARecSheet:
isRec = "NO"
Exit Function
NoMatch:
ThisWorkbook.Worksheets(ReconComp).Activate
Range("A13").Select
isRec = "No Match"
End Function
Sub UpdatedSegments()
Load frmPBar
With frmPBar
.Caption = "Looking for the " & OracleFileName & " flie..."
.LabelProgress.Width = 0
.Show False
End With
Application.ScreenUpdating = False
OracleFileName = "WEBUpdatedSegmentValueListing.xls"
ReportTitle = "Account #"
NewTabName = "Account"
On Error Resume Next
HP = ThisWorkbook.Worksheets("Settings").Range("SVLHypeLink").Text
Workbooks.Open (HP)
ThisWorkbook.Activate
On Error GoTo nextW
For Each w In Workbooks
If w.Name <> ThisWorkbook.Name Then
For Each S In w.Worksheets
If S.Name = "Settings" Then
If S.Range("C5") = "Segment Value Listing" Then
OracleFileName = w.Name
GoTo UpdateSegments
End If
End If
Next S
End If
nextW:
Next w
Response = MsgBox("The wizard can not find the Segment Value Listing file." & _
Chr(13) & Chr(13) & _
"Please download and open the Segment Value Listing file from the Accounting room on Channel*E and try again.", Button, Title)
GoTo EndIt
UpdateSegments:
On Error Resume Next
'update the progress bar
PctDone = 0.2
Task = "Deleting Account and Company tabs..."
UpdateProgressBar PctDone, Task
Application.StatusBar = Task
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Account").Delete
ThisWorkbook.Sheets("Company").Delete
Application.DisplayAlerts = True
'update the progress bar
PctDone = 0.4
Task = "Copying new tabs..."
UpdateProgressBar PctDone, Task
Application.StatusBar = Task
Workbooks(OracleFileName).Worksheets("Account").Copy After:=ThisWorkbook.Sheets("Settings")
Workbooks(OracleFileName).Worksheets("Company").Copy After:=ThisWorkbook.Sheets("Settings")
'update the progress bar
PctDone = 0.6
Task = "Deleting unwanted columns..."
UpdateProgressBar PctDone, Task
Application.StatusBar = Task
ThisWorkbook.Sheets("Settings").Range("LastUpdated") = ThisWorkbook.Sheets("Account").Range("D2")
ThisWorkbook.Sheets("Settings").Range("Version") = ThisWorkbook.Sheets("Settings").Range("Version") + 0.01
ThisWorkbook.Sheets("Account").Columns("C:F").Delete Shift:=xlToLeft
ThisWorkbook.Sheets("Company").Columns("C:F").Delete Shift:=xlToLeft
ThisWorkbook.Sheets("Account").Visible = False
ThisWorkbook.Sheets("Company").Visible = False
'update the progress bar
PctDone = 0.8
Task = "Calculating..."
UpdateProgressBar PctDone, Task
Application.StatusBar = Task
Workbooks(OracleFileName).Close savechanges:=False
Calculate
EndIt:
Unload frmPBar
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Sub UpdateTB()
OracleFileName = "CONS_-_TB_By_Co___Acc.xls"
Load frmPBar
With frmPBar
.Caption = "Looking for the " & OracleFileName & " flie..."
.LabelProgress.Width = 0
.Show False
End With
Application.ScreenUpdating = False
ReportTitle = "Trial Balance - All Companies"
NewTabName = "Output 1"
On Error GoTo nextW
For Each w In Workbooks
If w.Name <> ThisWorkbook.Name Then
For Each S In w.Worksheets
If S.Name = NewTabName Then
'update range from B3 to C1
If S.Range("C1") = ReportTitle Or S.Range("A3") = ReportTitle Then
OracleFileName = w.Name
GoTo UpdateSegments
End If
End If
Next S
End If
nextW:
Next w
Response = MsgBox("The wizard can not find the " & ReportTitle & " file.", Button, Title)
GoTo EndIt
UpdateSegments:
On Error Resume Next
'update the progress bar
PctDone = 0.2
Task = "Deleting old data"
UpdateProgressBar PctDone, Task
Application.StatusBar = Task
'ThisWorkbook.Worksheets("Settings").Range("TBDate") = Workbooks(OracleFileName).Worksheets(NewTabName).Range("A7").Value & _
Workbooks(OracleFileName).Worksheets(NewTabName).Range("B7").Value
ThisWorkbook.Worksheets("Settings").Range("TBDate") = "Submitted: " & Mid(Workbooks(OracleFileName).Worksheets(NewTabName).Range("E1").Value, 6, 7) & _
Right(Workbooks(OracleFileName).Worksheets(NewTabName).Range("E1").Value, 11)
Worksheets("Oracle").Unprotect Password:=Pass
Worksheets("Oracle").Range("A1:F1").AutoFilter
Range(Worksheets("Oracle").Range("A2"), Worksheets("Oracle").Range("F2").End(xlDown)).ClearContents
'changed "E2" to "F2"
'update the progress bar
PctDone = 0.4
Task = "Setting up the new TB"
UpdateProgressBar PctDone, Task
Application.StatusBar = Task
Set RangeStart = Workbooks(OracleFileName).Worksheets(NewTabName).Range("A13")
RangeStart.End(xlDown).Offset(1, 0).EntireRow.Delete 'remove the space after cash accounts
Set RangeFinish = Workbooks(OracleFileName).Worksheets(NewTabName).Range("A13").End(xlDown)
RangeStart.Offset(0, 4).Formula = "=left(A13,4)" 'put the company formula in column D
RangeStart.Offset(0, 5).Formula = "=mid(A13,7,7)" ' put the account formula in column E
Range(RangeStart.Offset(0, 4), RangeStart.Offset(0, 5)).Copy ' copy the formulas
Range(RangeStart.Offset(1, 4), RangeFinish.Offset(0, 5)).PasteSpecial xlPasteFormulas ' paste the formulas all the way down
Workbooks(OracleFileName).Worksheets(NewTabName).Calculate
Range(RangeStart.Offset(0, 4), RangeFinish.Offset(0, 5)).Copy 'copy the company and accounts
Range(RangeStart.Offset(0, 4), RangeFinish.Offset(0, 5)).PasteSpecial xlPasteValues 'paste values to save space
RangeStart.Formula = "=E13&F13"
RangeStart.Copy ' copy the formulas
Range(RangeStart, RangeFinish).PasteSpecial xlPasteFormulas ' paste the formulas all the way down
Workbooks(OracleFileName).Worksheets(NewTabName).Calculate
Range(RangeStart, RangeFinish).Copy 'copy the company and accounts
Range(RangeStart, RangeFinish).PasteSpecial xlPasteValues 'paste values to save space
'update the progress bar
PctDone = 0.6
Task = "Deleting IS accounts..."
UpdateProgressBar PctDone, Task
Application.StatusBar = Task
Range(RangeStart, RangeFinish.Offset(0, 5)).Sort key1:=RangeStart.Offset(0, 5)
Set RangeStart = Workbooks(OracleFileName).Worksheets(NewTabName).Range("A13")
Set RangeFinish = Workbooks(OracleFileName).Worksheets(NewTabName).Cells.Find(What:="4010100", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
'update the progress bar
PctDone = 0.8
Task = "Copy the TB to this workbook..."
UpdateProgressBar PctDone, Task
Application.StatusBar = Task
Range(RangeStart, RangeFinish.Offset(-1, 5)).Copy
'changed above line from a offset of 0 to -1 to remove the account 4010100 from the range
RangeStart.Select
ThisWorkbook.Worksheets("Oracle").Range("A2").PasteSpecial xlPasteValues
Worksheets("Oracle").Range("A1:F1").AutoFilter
'update the progress bar
PctDone = 0.99
Task = "Closing the TB..."
UpdateProgressBar PctDone, Task
Application.StatusBar = Task
Application.DisplayAlerts = False
Workbooks(OracleFileName).Close savechanges:=False
Application.DisplayAlerts = True
EndIt:
SheetCalc
Unload frmPBar
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Sub UpdateProgressBar(PctDone As Single, Task)
With frmPBar
.Caption = Task 'update the caption on the frame
.FrameProgress.Caption = Format(PctDone, "0%") ' Update the Caption property of the Frame control.
.LabelProgress.Width = PctDone * .FrameProgress.Width ' Widen the Label control.
If PctDone = 0 Then .Repaint
'.LabelProgress.Caption = " macro running, Please wait..." 'show text on the bar
End With
DoEvents ' The DoEvents allows the UserForm to update.
End Sub
Sub UpdateDoublePBar()
'Update the status bar
'Application.StatusBar = Task & " " & Application.Rept(Chr(1) & " ", SqrNum * 5)
'Application.StatusBar = "Working... " & Format(pbPctDone, "0%")
With DoublePBar
'update the caption on the frame
'.Caption = Task
' Update the Caption property of the Frame control.
.ProgressDescription1 = ThisWorkbook.Worksheets("settings").Range("Task1")
.ProgressDescription2 = ThisWorkbook.Worksheets("settings").Range("Task2")
.ProgressDescription3 = ThisWorkbook.Worksheets("settings").Range("Task3")
' Widen the Label control.
.Progress1.Width = .FrameProgress1.Width * ThisWorkbook.Worksheets("settings").Range("PC1").Value
.Progress2.Width = .FrameProgress2.Width * ThisWorkbook.Worksheets("settings").Range("PC2").Value
.Progress3.Width = .FrameProgress3.Width * ThisWorkbook.Worksheets("settings").Range("PC3").Value
'If PctDone = 0 Then .Repaint
'show text on the bar
'.LabelProgress.Caption = Task
'show the progress lable
.ProgressCount1 = Format(ThisWorkbook.Worksheets("settings").Range("PC1").Value, "0%")
.ProgressCount2 = Format(ThisWorkbook.Worksheets("settings").Range("PC2").Value, "0%")
.ProgressCount3 = Format(ThisWorkbook.Worksheets("settings").Range("PC3").Value, "0%")
End With
' The DoEvents allows the UserForm to update.
DoEvents
End Sub
Sub EndIt()
SheetCalc
Unload frmPBar
Application.ScreenUpdating = True
Application.StatusBar = False
On Error GoTo ProtectWithoutColumns
ActiveSheet.Protect Password:=Pass, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFiltering:=True
Exit Sub
ProtectWithoutColumns:
ActiveSheet.Protect Password:=Pass
End Sub
Sub doCB3()
Msg = MsgBox("Are you sure you want to stop the wizard?" & Chr(13) & Chr(13) _
& "There are still " & FileCount - iFile & " files left in " & FolderCount - iFolder & " folders left to process." & Chr(13) & Chr(13) _
& "The last folder processed is: " & Chr(13) & Chr(13) _
& " " & Folder & Chr(13) & Chr(13) _
& "Click Yes to save the file and exit." & Chr(13) & Chr(13) _
& "Click No to continue.", vbYesNo, Title)
If Msg = vbYes Then
ExitItAll = True
ThisWorkbook.Worksheets("Settings").Range("LastFolder") = Folder
Application.StatusBar = "Saving " & ThisWorkbook.Name
ThisWorkbook.Save
End If
End Sub
Sub doCB2()
Application.StatusBar = "Saving " & ThisWorkbook.Name
ThisWorkbook.Save
End Sub
Sub doCB1()
SkipThisFolder = True
End Sub
Function OpenFile(HP)
' Open the file dialog
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Show
' Open the file
HP = .SelectedItems(1)
End With
Workbooks.Open Filename:=HP, ReadOnly:=True
HP = ActiveWorkbook.Name
End Function
