VBA to copy and paste individual cells onto a master file...

[pcapasso]

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:
[TABLE="width: 384"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Cell[/TD]
[TD]Task on "Test File"[/TD]
[/TR]
[TR]
[TD]ACCT[/TD]
[TD]E6[/TD]
[TD]Match to column A of master file[/TD]
[/TR]
[TR]
[TD]AgedD[/TD]
[TD]M12[/TD]
[TD]Paste into corresponding ACCT Column K[/TD]
[/TR]
[TR]
[TD]AgedD0[/TD]
[TD]M5[/TD]
[TD]Paste into corresponding ACCT Column S[/TD]
[/TR]
[TR]
[TD]AgedD3[/TD]
[TD]M7[/TD]
[TD]Paste into corresponding ACCT Column U[/TD]
[/TR]
[TR]
[TD]AgedD6[/TD]
[TD]M9[/TD]
[TD]Paste into corresponding ACCT Column W[/TD]
[/TR]
[TR]
[TD]AgedI[/TD]
[TD]M11[/TD]
[TD]Paste into corresponding ACCT Column L[/TD]
[/TR]
[TR]
[TD]AgedI0[/TD]
[TD]M6[/TD]
[TD]Paste into corresponding ACCT Column R[/TD]
[/TR]
[TR]
[TD]AgedI3[/TD]
[TD]M8[/TD]
[TD]Paste into corresponding ACCT Column T[/TD]
[/TR]
[TR]
[TD]AgedI6[/TD]
[TD]M10[/TD]
[TD]Paste into corresponding ACCT Column V[/TD]
[/TR]
[TR]
[TD]Comp[/TD]
[TD]E4[/TD]
[TD]Matches "Entity" on Test File (named)[/TD]
[/TR]
[TR]
[TD]glbal[/TD]
[TD]M14[/TD]
[TD]Paste into corresponding ACCT Column O[/TD]
[/TR]
[TR]
[TD]pby[/TD]
[TD]K17[/TD]
[TD]Paste into corresponding ACCT Column D[/TD]
[/TR]
[TR]
[TD]Prepared[/TD]
[TD]M17[/TD]
[TD]If not blank, YES in corresponding Column H[/TD]
[/TR]
[TR]
[TD]rby[/TD]
[TD]K19[/TD]
[TD]Paste into corresponding ACCT Column E[/TD]
[/TR]
[TR]
[TD]Reviewed[/TD]
[TD]M19[/TD]
[TD]If not blank, YES in corresponding Column I[/TD]
[/TR]
[TR]
[TD]risk[/TD]
[TD]M15[/TD]
[TD]Paste into corresponding ACCT Column M[/TD]
[/TR]
</tbody>[/TABLE]


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!!

'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