Want one macro code wherein I need to copy the data as it is reflecting in the source file (BS Tab only) however if I run the macro the format changes. Rest all the tabs are working properly. Please someone help me out. Below mention are the coding which I used in my macro
VBA Code:
Sub ChangeFormat()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Rng As Range
Dim folderSelect As FileDialog
Dim inputFolder As String
Dim fileName As String
Dim wbInput As Workbook
Dim wsInput As Worksheet
Dim logRow As Integer
Dim fileType As Variant
Dim HasMergedCells As Boolean
Dim HasEmptyRows As Boolean
Dim HasExtraColumn As Boolean
Dim altNamesPA As Variant
Dim altNamesInv As Variant
altNamesPA = Array("PA (YTD)", "PA (YTD) (Carry Broken Out)", "PA YTD", "PA (YTD)")
altNamesInv = Array("Inv. Summary", "Invst. Summary", "Investment Rollforward YTD")
altNamesBS = Array("Balance Sheet", "BS", "BalanceSheet")
' select directory for processing
Set folderSelect = Application.FileDialog(msoFileDialogFolderPicker)
With folderSelect
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.path
If .Show <> -1 Then GoTo EndOfSub
inputFolder = .SelectedItems(1)
End With
' loop through Excel files in selected directory
logRow = 1
fileName = Dir(inputFolder & "\*.xl*")
If Len(fileName) = 0 Then
MsgBox "No *.xl files found in selected folder."
GoTo EndOfSub
End If
Do While Len(fileName) > 0
Set wbInput = Workbooks.Open(inputFolder & "\" & fileName)
For Each fileType In Array("PA", "BS", "Inv.")
' select the proper sheet, checking for alternative names and changing sheet name accordingly
If fileType = "PA" Then
For Each altName In altNamesPA
If WorksheetExists(altName, wbInput) Then
Set wsInput = wbInput.Sheets(altName)
wsInput.Name = "PA (YTD)"
GoTo FixSheet
End If
Next altName
ElseIf fileType = "BS" Then ' Simple case: no alternative names for this
For Each altName In altNamesBS
If WorksheetExists(altName, wbInput) Then
Set wsInput = wbInput.Sheets(altName)
wsInput.Name = "BS"
GoTo FixSheet
End If
Next altName
ElseIf fileType = "Inv." Then
For Each altName In altNamesInv
If WorksheetExists(altName, wbInput) Then
Set wsInput = wbInput.Sheets(altName)
wsInput.Name = "Inv. Summary"
GoTo FixSheet
End If
Next altName
End If
' If you still haven't met a goto at this point, then the sheet wasn't found: skip and log
Call LogChange("Unable to find a '" & fileType & "' filetype.", wbInput.Sheets(1))
GoTo EndOfFileTypeLoop
FixSheet:
' Unmerge all cells and copy values
HasMergedCells = False
For Each Rng In wsInput.UsedRange
If Rng.MergeCells Then
HasMergedCells = True
With Rng.MergeArea
.UnMerge
.Formula = Rng.Formula
End With
End If
Next
If HasMergedCells Then
Call LogChange("Cells unmerged!", wsInput)
End If
' Delete empty top rows
HasEmptyRows = False
For i = 1 To 10
If wsInput.Cells(1, 1) <> "Legal Entity" And wsInput.Cells(1, 1) <> "Fund" Then
HasEmptyRows = True
wsInput.Rows(1).Delete
Else
Exit For
End If
Next i
If HasEmptyRows Then
Call LogChange("Top row(s) deleted!", wsInput)
End If
' Remove/rename extra columns
If fileType = "PA" Then
Call DeleteColumnIfExists("Vehicle", wsInput)
Call DeleteColumnIfExists("Carry Accrual - Unrealized", wsInput)
Call DeleteColumnIfExists("Deferred Tax Expense", wsInput)
Call RenameColumnIfExists("Carry Accrual - Realized", "Carry Accrual", wsInput)
Call RenameColumnIfExists("Management / Drawdown Fees", "Management Fee", wsInput)
' In some files, the "net investor irr" column is duplicated at the end: remove one if there are 2
If Application.WorksheetFunction.CountIf(wsInput.Rows(1), "Net Investor IRR") = 2 Then
Call DeleteColumnIfExists("Net Investor IRR", wsInput)
End If
End If
If fileType = "Inv." Then
Call AddColumnIfDoesntExist("Deal Commitment", 4, wsInput)
Call AddColumnIfDoesntExist("Unfunded Deal Commitment", 7, wsInput)
End If
Call ValidateFormat(wsInput, CStr(fileType))
EndOfFileTypeLoop:
Next fileType
' Save a copy if any changes were made
If Not wbInput.Saved Then
With CreateObject("Scripting.FileSystemObject")
Dim path As String
path = wbInput.path & "\updated\"
If Not .FolderExists(path) Then
.CreateFolder path
End If
End With
wbInput.SaveAs fileName:=path & "UPDATED-" & wbInput.Name ' remove "updated-" ?
End If
wbInput.Close SaveChanges:=False
fileName = Dir
Loop
MsgBox ("Finished! Check log sheet for details.")
EndOfSub:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub LogChange(msg As String, ws As Worksheet, Optional isVerbose As Boolean = True)
Dim wsLog As Worksheet
Dim lastRow As Long
Dim logVerbose As Boolean
logVerbose = ThisWorkbook.Sheets("Cover").Cells(3, 10)
If isVerbose And Not logVerbose Then
Exit Sub
End If
Set wsLog = ThisWorkbook.Sheets("Log")
lastRow = wsLog.Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row
wsLog.Cells(lastRow, 1) = Format(Now, "mm/dd/yyyy HH:mm:ss")
wsLog.Cells(lastRow, 2) = ws.Parent.Name
wsLog.Cells(lastRow, 3) = ws.Name
wsLog.Cells(lastRow, 4) = msg
End Sub
Sub DeleteColumnIfExists(header As String, ws As Worksheet)
On Error GoTo SubEnd
ws.Columns(Application.WorksheetFunction.Match(header, ws.Rows(1), 0)).Delete
Call LogChange("''" & header & "' column deleted!", ws)
SubEnd:
On Error GoTo 0
End Sub
' This is a stupid function for an edge case: check if the column already exists. If it doesn't, add at the specified index
Sub AddColumnIfDoesntExist(newColumnName As String, colNumber As Long, ws As Worksheet)
On Error GoTo SubEnd
If Application.WorksheetFunction.CountIf(ws.Rows(1), newColumnName) > 0 Then
GoTo SubEnd
End If
ws.Columns(colNumber).Insert
ws.Cells(1, colNumber).Value = newColumnName
SubEnd:
On Error GoTo 0
End Sub
Sub RenameColumnIfExists(header As String, rename As String, ws As Worksheet)
On Error GoTo SubEnd
ws.Cells(1, Application.WorksheetFunction.Match(header, ws.Rows(1), 0)).Value = rename
Call LogChange("''" & header & "' column renamed to '" & rename & "'!", ws)
SubEnd:
On Error GoTo 0
End Sub
Sub ValidateFormat(ws As Worksheet, formatType As String)
Dim expectedColumns As Variant
endDate = ThisWorkbook.Sheets("Cover").Cells(4, 11).Value
beginningDate = ThisWorkbook.Sheets("Cover").Cells(3, 11).Value
If formatType = "BS" Then
expectedColumns = Array("Legal Entity", "GL Account", "Account Type", "Dr/(Cr) amount")
ElseIf formatType = "PA" Then
expectedColumns = Array("Fund", "Investor", "Commitment", "Beginning Balance as of *", _
"Contributions", "Transfers", "Distributions", "Investment Income / (Expenses)", "Operating Expenses", _
"Management Fee", "Realized Gains / (Losses)", "Unrealized Gains / (Losses)", "Carry Accrual", _
"Ending Balance as of *", "Unfunded Commitment", "Net Investor IRR")
ElseIf formatType = "Inv." Then
expectedColumns = Array("Legal Entity", "Deal Name", "FOF/Direct", "Deal Commitment", _
"Cost Basis *", "Fair Value *", "Unfunded Deal Commitment", "IRR @ MV")
Else
Exit Sub
End If
For i = 1 To UBound(expectedColumns)
If InStr(expectedColumns(i - 1), "*") Then
If Not ws.Cells(1, i) Like expectedColumns(i - 1) Then
Call LogChange("Failed validation: did not find expected date column: '" & expectedColumns(i - 1) & "' Instead found: '" & ws.Cells(1, i) & "'", ws, False)
Exit Sub
End If
ElseIf ws.Cells(1, i) <> expectedColumns(i - 1) Then
Call LogChange("Failed validation: did not find expected column: '" & expectedColumns(i - 1) & "' Instead found: '" & ws.Cells(1, i) & "'", ws, False)
Exit Sub
End If
Next i
If ws.Cells(1, i + 1) <> "" Then
Call LogChange("Extra columns found at end.", ws, False)
Else
Call LogChange("Successfully validated!", ws, False)
End If
End Sub
' H/T [URL='https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists']Test or check if sheet exists[/URL]
Function WorksheetExists(shtName As Variant, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
Last edited by a moderator:
