Hi Friends,
I have the below macro, which will consolidate multiple excel sheets to Single excel sheet in different file name.
Here the Function "BIC" is not working. Could someone help me on the same please.
I have the below macro, which will consolidate multiple excel sheets to Single excel sheet in different file name.
Here the Function "BIC" is not working. Could someone help me on the same please.
Code:
Sub Select_File_Or_Files_Windows_test()
Dim SaveDriveDir As String
Dim MyPath As String
Dim Fname As Variant
Dim N As Long
Dim FnameInLoop As String
Dim mybook As Workbook
Dim destWORKbook As String
Dim DestWB As Workbook
Dim dealsSummary As Worksheet
Dim deals As Worksheet
Dim ctpyFound As Worksheet
Dim todayDate As String
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="Excel 97-2003 Files (*.xls), *.xls", _
Title:="Select a file or files", _
MultiSelect:=True)
' Save the current directory.
SaveDriveDir = CurDir
' Create a new workbook and set a variable to the first sheet.
Set DestWB = Workbooks.Add
Set DestWB = ActiveWorkbook
DestWB.Sheets(1).name = "All"
'DestWB.Sheets(2).Name = "Deals"
'DestWB.Sheets(3).Name = "Cpty Found"
todayDate = Format(Now(), "DD-MMM-YYYY")
With DestWB
Application.DisplayAlerts = False
destWORKbook = SaveDriveDir & "\" & "PCM Charges " & todayDate & ".xlsx"
If (Dir(destWORKbook) <> "") Then
' First remove readonly attribute, if set
SetAttr destWORKbook, vbNormal
' Then delete the file
Kill destWORKbook
End If
.SaveAs Filename:=destWORKbook
Set DestWB = ActiveWorkbook
End With
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
currentData = processWorkbook(FnameInLoop, N, destWORKbook, SaveDriveDir, DestWB)
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
'Save output file
Sheets(1).Select
Selection.EntireColumn.AutoFit
Range("A2").Select
Sheets(1).Select
MoveData
Columns("P:AD").EntireColumn.Delete
Range("A1").EntireColumn.Insert
BIC
ActiveWorkbook.Save
ActiveWorkbook.Close
If N = 0 Then
MsgBox "Select files to Proceed!"
Else
MsgBox "Done! Consolidated file saved at " & SaveDriveDir
End If
End Sub
Function processWorkbook(ByRef szBookName As String, counter As Long, destWORKbook As String, filePath As String, DestWBref As Workbook)
Dim LastCell As String
Dim rng As Range
Dim SourceWB As Workbook
Dim WBSource As String
Dim lRow As Long
Dim LastRow As String
Dim DestinationRange As Range
' For choice = 1 To 3
Set x = Workbooks.Open(szBookName)
Workbooks.Open(szBookName).Activate
Set SourceWB = ActiveWorkbook
toSelectSheet = "All"
SourceWB.Sheets(toSelectSheet).Select
Columns(1).EntireColumn.Delete
Set rng = Sheets(toSelectSheet).Cells
LastCell = Last(3, rng)
If counter = 1 Then
startRange = "A4"
Else
startRange = "A5"
' If LastCell = "F2" Or LastCell = "P2" Or LastCell = "N2" Then
' startRange = "A3"
' LastCell = "F3"
' End If
End If
'## Open both workbooks first:
Set InputFile = ActiveWorkbook
'Copy and paste
Sheets(toSelectSheet).Select
Range(startRange, LastCell).Select
Range(startRange, LastCell).UnMerge
Selection.Copy
DestWBref.Activate
Sheets(toSelectSheet).Select
If counter = 1 Then
Selection.PasteSpecial 'xlPasteValues, xlPasteSpecialOperationNone
Application.CutCopyMode = False
Else
lRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
LastRow = "A" & lRow
Range(LastRow).Select
Selection.PasteSpecial 'xlPasteValues, xlPasteSpecialOperationNone
Application.CutCopyMode = False
End If
SourceWB.Close
Selection.Offset(, 14) = Mid(szBookName, 12, 2)
End Function
Function Last(choice As Long, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
Dim lrw As Long
Dim lcol As Long
Select Case choice
Case 1:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
End Function
Sub MoveData()
Dim rng As Range
Application.ScreenUpdating = False
On Error Resume Next
Set rng = [I:I].SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
rng.FormulaR1C1 = "=IF(RC[-1]="""","""",RC[-1])"
[I:I] = [I:I].Value
End If
rng.Offset(0, -1).ClearContents
End Sub
Sub BIC()
Dim lRow As Long
Dim SourceRange As Range, DestinationRange As Range, i As Integer
Dim SourceFullRange1 As String, DestFullRange1 As String
Dim strListSheet As String
lRow = Cells(Columns.Count, 15).End(xlUp).Row
SourceFullRange1 = "P2:P" & lRow
Set SourceRange = Sheet1.Range(SourceFullRange1)
DestFullRange1 = "A2:A" & lRow
Set DestinationRange = Sheet2.Range(DestFullRange1)
For i = 1 To lRow
DestinationRange(i, 1).FormulaR1C1 = "=IF(RC[15]=""AT"",""GEBAAT"",IF(RC[15]=""BG"",""BNPAB"",IF(RC[15]=""CZ"",""GEBACZ"",IF(RC[15]=""DE"",""BNPAX"",IF(RC[15]=""DK"",""FTSBDKKKXXX"",IF(RC[15]=""ES"",""BNPAE"", IF(RC[15]=""ESF"",""GEBAE"",IF(RC[15]=""HU"",""BNADSE"",IF(RC[15]=""IE"",""BNAIXX"", IF(RC[15]=""NL"", ""BNNL2X"", IF(RC[15]=""NO"", ""BNOKKX"", if(RC[15]=""PL"", ""BNLPXX"", IF(RC[15]=""PT"", ""BNTXX"",IF(RC[15]=""RO"", ""FTSBROB"", ""FTSSXX""))))))))))))))"
Next i
Columns(1).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
End Sub
