Sub GetDataV3_2()
'
Application.ScreenUpdating = False
'
Dim FirstRunComplete As Boolean
Dim ColumnK_Number As Long
Dim CurrentRowColumnM_Value As Long
Dim DesiredMatchRowNumber As Long
Dim FormulaLooper As Long
Dim i As Long, ini As Long, j As Long, k As Long
Dim InnerFormulaLooper As Long
Dim LastColumnNumberSheetB As Long
Dim LastRow As Long
Dim MatchCount As Long
Dim OccurrenceCounter As Long
Dim RangeK_FormulaRows As Long
Dim RowNumber As Long
Dim VchNo As Long
Dim cell As Range
Dim Fnd As Range
Dim rFound As Range
Dim rngReferenceRange As Range, rngToCopy As Range
Dim LastColumnLetterSheetB As String
Dim NewName As String
Dim a As Variant, b As Variant, c As Variant
Dim ColumnI_Array As Variant
Dim RangeK_Array As Variant
Dim WS As Worksheet
'
'-----------------------------------------------------------------------------------------
'
With Sheets("Bank") ' Copy Columns A:I from 'Original' to 'Bank'
Sheets("Original").Columns("A:I").Copy .Range("A1")
.UsedRange.UnMerge
Set Fnd = .Range("A:A").Find("Date", , , xlPart, xlByRows, xlNext, False, , False)
If Not Fnd Is Nothing And Fnd.Row > 1 Then ini = Fnd.Row + 2 Else ini = 1 ' If "Date" found in Column A in row>1 then set ini to 2 rows down
a = .Range("A" & ini, .Range("I" & .Rows.Count).End(3)).Value ' Load array 'a' with the data from Columns A:I
End With
'
ReDim b(1 To UBound(a), 1 To 7)
ReDim c(1 To UBound(a), 1 To 7)
'
For i = 1 To UBound(a) - 3
If LCase(a(i, 3)) <> LCase("(as per details)") And a(i, 6) <> "" Then ' If Column C value <> '(as per details)' & column F value <> "" then...
j = j + 1
b(j, 1) = i 'Line ' save row# & all column values A:I except B,D,E to array 'b'
b(j, 2) = a(i, 1) 'Date
b(j, 3) = a(i, 6) 'Vch Type
b(j, 4) = a(i, 7) 'Vch No.
b(j, 5) = a(i, 3) 'Particulars
b(j, 6) = a(i, 8) 'Debit
b(j, 7) = a(i, 9) 'Credit
Else ' Else
k = k + 1
c(k, 1) = i 'Line
c(k, 2) = a(i, 1) 'Date ' save row# & all other column values A:I except B,D,E to array 'c'
c(k, 3) = a(i, 6) 'Vch Type
c(k, 4) = a(i, 7) 'Vch No.
c(k, 5) = a(i, 3) 'Particulars
c(k, 6) = a(i, 8) 'Debit
c(k, 7) = a(i, 9) 'Credit
End If
Next
'
With Sheets("Bank")
.UsedRange.Clear ' Clear the data that we copied to 'Bank'
.Range("A1:G1").Value = Array("Line", "Date", "Vch Type", "Vch No.", "Particulars", "Debit", "Credit") ' add headers
.Range("A2").Resize(j, 7).Value = b ' Display array 'b' to sheet
.Range("A" & j + 3).Resize(k, 7).Value = c ' display array 'c' to sheet
'
' Format the data
.Columns("F:G").NumberFormat = "0.00"
.UsedRange.EntireColumn.AutoFit
.UsedRange.HorizontalAlignment = xlLeft
.Range("B:B").NumberFormat = "dd-mm-yyyy"
End With
'
NewName = Sheets("Original").Range("K1") ' Get name saved in 'Original' K1
VchNo = 1000 ' Initialize VchNo = 1000
'
For Each cell In Sheets("Bank").Range("D2:D" & Sheets("Bank").Range("E" & Sheets("Bank").Rows.Count).End(xlUp).Row)
If Not cell.Offset(, -1) = vbNullString Then ' Check for non blanks to left of Column D values
VchNo = VchNo + 1
cell.Value = VchNo ' Renumber VchNo's
End If
'
If cell.Offset(0, 1) = "(as per details)" Then cell.Offset(0, 1).Value = NewName ' If cell to right of Column D value =
' ' (as per details)' then rename that cell value
Next
'
Set rngReferenceRange = Sheets("Bank").Range("A1").CurrentRegion
Set rngToCopy = Sheets("Bank").Cells(rngReferenceRange.Rows.Count + 2, 1).CurrentRegion
'
rngToCopy.Copy ' Copy now updated former array 'c' values
'
'---------------------------------------------------------------------------------------------------------------------
'
With Sheets("A")
.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' Paste now updated former array 'c' values to 'A'
Application.CutCopyMode = False
'
.Columns("B:B").NumberFormat = "dd-mm-yyyy"
.Columns("E:E").Insert Shift:=xlToRight
.Columns("G:H").Insert Shift:=xlToRight
'
.Range("G1").FormulaR1C1 = "=IF(RC[2]="""","""",-RC[2])"
.Range("H1").FormulaR1C1 = "=IF(RC[2]="""","""",RC[2])"
.Range("G1:H1").AutoFill Destination:=.Range("G1:H" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With
'
With Sheets("A").Range("B2:D" & Sheets("A").Range("A" & Rows.Count).End(xlUp).Row)
.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C" ' Fill blank cells in Columns B:D with cell value above it
.Value = .Value
End With
'
With Sheets("A")
.Columns("D").NumberFormat = "0"
.Columns("G:H").NumberFormat = "0.00"
'
.Range("B1:H1", .Range("B1:H1").End(xlDown)).Copy
.Range("B1:H1", .Range("B1:H1").End(xlDown)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'
.Range("B1:H1", .Range("B1:H1").End(xlDown)).Copy Sheets("B").Range("A3")
End With
'
'
' This should be a good place to evaluate the formulas for Sheets("B") ;)
'
ColumnK_Number = 11
RowNumber = 3
LastColumnLetterSheetB = Split(Sheets("B").Range("K2").End(xlToRight).Address, "$")(1) ' Get last column letter used in row 2 of Sheets("B")
LastColumnNumberSheetB = Sheets("B").Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column ' Find last column # used in Sheets("B")
'
Set WS = Worksheets("B")
LastRow = WS.Range("A" & Rows.Count).End(xlUp).Row
'
'--------------------------------------------------------------------------------------------------------------------------------------
'
ReDim ColumnI_Array(1 To LastRow - 2)
'
For FormulaLooper = RowNumber To LastRow ' Column I formulas
ColumnI_Array(FormulaLooper - 2) = WS.Evaluate("=IF(A2="""","""",SUM(F" & FormulaLooper & ":G" & FormulaLooper & "))")
Next
'
WS.Range("I3:I" & LastRow) = Application.Transpose(ColumnI_Array)
'
'--------------------------------------------------------------------------------------------------------------------------------------
'
' Count cells that are not blank in Sheets("B") Column E to get # of formula rows needed for Sheets("B") Columns K3 range ;)
RangeK_FormulaRows = Application.WorksheetFunction.CountIf(Sheets("B").Range("E3:E" & LastRow), Sheets("Original").Range("K1"))
'
ReDim RangeK_Array(1 To RangeK_FormulaRows, 1 To LastColumnNumberSheetB - ColumnK_Number + 1)
'
For FormulaLooper = RowNumber To RowNumber + RangeK_FormulaRows - 1
OccurrenceCounter = OccurrenceCounter + 1
'
Set rFound = WS.Range("E2:E" & LastRow).Cells(1, 1)
'
For MatchCount = 1 To OccurrenceCounter
Set rFound = WS.Range("E2:E" & LastRow).Find(Sheets("Original").Range("K1"), rFound, xlValues, xlWhole)
Next
'
DesiredMatchRowNumber = rFound.Row
CurrentRowColumnM_Value = WS.Evaluate("=IFERROR(INDEX($C$3:$C$" & LastRow & "," & DesiredMatchRowNumber & "),"""")")
'
RangeK_Array(FormulaLooper - 2, 1) = WS.Evaluate("=IFERROR(INDEX($A$3:$I$" & LastRow & ",MATCH(" & _
CurrentRowColumnM_Value & ",$C$3:$C$" & LastRow & ",0),1),"""")") ' Save $K3 value
'
RangeK_Array(FormulaLooper - 2, 2) = WS.Evaluate("=IFERROR(INDEX($A$3:$I$" & LastRow & ",MATCH(" & _
CurrentRowColumnM_Value & ",$C$3:$C$" & LastRow & ",0),2),"""")") ' Save $L3 value
'
RangeK_Array(FormulaLooper - 2, 3) = WS.Evaluate("=IFERROR(INDEX($C$3:$C$" & LastRow & "," & _
DesiredMatchRowNumber & "),"""")") ' Save $M3 value
'
RangeK_Array(FormulaLooper - 2, 4) = WS.Evaluate("=IF(IFERROR(INDEX($A$3:$I$" & LastRow & _
",AGGREGATE(15,6,(ROW($C$3:$C$" & LastRow & ")-ROW($C$2))/($C$3:$C$" & LastRow & "=" & _
CurrentRowColumnM_Value & "),INT((COLUMNS(N" & FormulaLooper + 1 & ":$O" & FormulaLooper + 1 & _
")+1)/2)),4),"""")="""","""")") ' Save $N3 value
'
RangeK_Array(FormulaLooper - 2, 5) = WS.Evaluate("=IF(" & CurrentRowColumnM_Value & _
"="""","""",IFERROR(INDEX($A$3:$I$" & LastRow & ",AGGREGATE(15,6,(ROW($C$3:$C$" & LastRow & _
")-ROW($C$2))/($C$3:$C$" & LastRow & "=" & CurrentRowColumnM_Value & "),INT((COLUMNS(O" & _
FormulaLooper + 1 & ":$O" & FormulaLooper + 1 & ")+1)/2)),5),""""))&""""") ' Save $O3 value
'
For InnerFormulaLooper = 5 To 45 Step 2
If FirstRunComplete Then
RangeK_Array(FormulaLooper - 2, InnerFormulaLooper + 1) = WS.Evaluate("=IF(" & RangeK_Array(FormulaLooper - 3, 3) & _
"="""","""",IFERROR(INDEX($A$3:$I$" & LastRow & ",AGGREGATE(15,6,(ROW($C$3:$C$" & LastRow & _
")-ROW($C$2))/($C$3:$C$" & LastRow & "=" & CurrentRowColumnM_Value & "),INT((COLUMNS($O" & _
FormulaLooper & ":" & WS.Range("K" & FormulaLooper).Offset(, InnerFormulaLooper).Address(0, 0) & _
")+1)/2)),9),""""))")
Else
RangeK_Array(FormulaLooper - 2, InnerFormulaLooper + 1) = WS.Evaluate("=IF(M" & FormulaLooper - 1 & _
"="""","""",IFERROR(INDEX($A$3:$I$" & LastRow & ",AGGREGATE(15,6,(ROW($C$3:$C$" & LastRow & _
")-ROW($C$2))/($C$3:$C$" & LastRow & "=" & CurrentRowColumnM_Value & "),INT((COLUMNS($O" & _
FormulaLooper & ":" & WS.Range("K" & FormulaLooper).Offset(, InnerFormulaLooper).Address(0, 0) & _
")+1)/2)),9),""""))")
End If
Next
'
For InnerFormulaLooper = 6 To 44 Step 2
If FirstRunComplete Then
RangeK_Array(FormulaLooper - 2, InnerFormulaLooper + 1) = WS.Evaluate("=IF(" & RangeK_Array(FormulaLooper - 3, 3) & _
"="""","""",IFERROR(INDEX($A$3:$I$" & LastRow & ",AGGREGATE(15,6,(ROW($C$3:$C$" & LastRow & _
")-ROW($C$2))/($C$3:$C$" & LastRow & "=" & CurrentRowColumnM_Value & "),INT((COLUMNS($O" & _
FormulaLooper + 1 & ":" & WS.Range("K" & FormulaLooper).Offset(1, InnerFormulaLooper).Address(0, 0) & _
")+1)/2)),5),""""))&""""")
Else
RangeK_Array(FormulaLooper - 2, InnerFormulaLooper + 1) = WS.Evaluate("=IF(M" & FormulaLooper - 1 & _
"="""","""",IFERROR(INDEX($A$3:$I$" & LastRow & ",AGGREGATE(15,6,(ROW($C$3:$C$" & LastRow & _
")-ROW($C$2))/($C$3:$C$" & LastRow & "=" & CurrentRowColumnM_Value & "),INT((COLUMNS($O" & _
FormulaLooper + 1 & ":" & WS.Range("K" & FormulaLooper).Offset(1, InnerFormulaLooper).Address(0, 0) & _
")+1)/2)),5),""""))&""""")
End If
Next
'
FirstRunComplete = True
Next
'
WS.Range("K3:" & LastColumnLetterSheetB & RangeK_FormulaRows + 2) = RangeK_Array
'
'
Dim Mx As Long
'
' this range needs to be changed
With Sheets("B")
Mx = Application.Max(.Range("K3:K" & .Range("K" & .Rows.Count).End(xlUp).Row))
'
Sheets("E").Range("A3:AT3").Resize(Mx).Value = .Range("K3:" & LastColumnLetterSheetB & "3").Resize(Mx).Value
End With
'
Sheets("F").Range("B2:AT2").Resize(Mx).Value = Sheets("E").Range("A3:AT3").Resize(Mx).Value
'
'
Sheets("Bank").Select
Range("A1").Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'
Sheets("Z").Select
Range("A2").Select
ActiveSheet.Paste
'
'
With Sheets("Z")
.UsedRange.EntireColumn.AutoFit
.Columns("F:G").Insert Shift:=xlToRight
.Range("F3").FormulaR1C1 = "=IF(RC[2]="""",RC[3],-RC[2])"
.Range("G3").FormulaR1C1 = "=-RC[-1]"
'
' this range needs to be changed
.Range("F3:G3").AutoFill Destination:=.Range("F3:G" & .Range("A" & .Rows.Count).End(xlUp).Row)
''' .Range("F2:G2").AutoFill Destination:=.Range("F2:G" & .Range("G" & .Rows.Count)).End(xlUp).Row
'
' this range needs to be changed
'' .Range("F2:G2000").Select
.Range("F3:G3", .Range("F3:G3").End(xlDown)).Copy
.Range("F3:G3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
'
Application.CutCopyMode = False
'
Dim rr As Long
Dim p As Variant
Dim pp As Variant
Dim s() As Variant
Dim ss() As Variant
'
s = Array(2, 3, 4, 5, 6, 7)
ss = Array(2, 3, 4, 8, 7, 9)
p = Sheets("Z").Cells(Sheets("Z").Rows.Count, 1).End(3).Row
pp = Sheets("F").Cells(Sheets("F").Rows.Count, 3).End(3).Row + 1
'
For rr = 0 To UBound(s)
Sheets("Z").Range(Sheets("Z").Cells(3, s(rr)), Sheets("Z").Cells(p, s(rr))).Copy Sheets("F").Cells(pp, ss(rr))
Next
'
Sheets("F").Cells(pp, "f").Resize(Sheets("F").Range("b" & Sheets("Z").Rows.Count).End(3).Row - pp + 1) = NewName
'
Application.CutCopyMode = True
'
'' With Sheets("Z").UsedRange
'' .Value = .Value
'' End With
'
Dim da As Long
Dim ku As Long
'
With Sheets("F").Range("A1").CurrentRegion
For da = 2 To .Rows.Count
If .Cells(da, 7) < 0 Then
ku = .Cells(da, .Columns.Count).End(xlToLeft).Column
.Cells(da, ku + 1).Resize(, 2).Value = .Cells(da, 6).Resize(, 2).Value
'
With .Cells(da, 6).Resize(, .Columns.Count)
.Value = .Offset(, 2).Value
End With
End If
Next
End With
'
With Sheets("F")
.UsedRange.HorizontalAlignment = xlGeneral
.Range("D2", .Range("D2").End(xlDown)).ClearContents
End With
'
Sheets("Original").Activate
Range("A2").Select
'
Application.ScreenUpdating = True
'
MsgBox ("File sorted successfully.")
End Sub
