Sub GetDataV3()
'
Application.ScreenUpdating = False
Application.Calculation = xlManual
'
Dim i As Long, ini As Long, j As Long, k As Long
Dim VchNo As Long
Dim cell As Range
Dim Fnd As Range
Dim rngReferenceRange As Range, rngToCopy As Range
Dim a As Variant, b As Variant, c As Variant
Dim NewName As String
'
'
With Sheets("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
a = .Range("A" & ini, .Range("I" & .Rows.Count).End(3)).Value
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
j = j + 1
b(j, 1) = i 'Line
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
k = k + 1
c(k, 1) = i 'Line
c(k, 2) = a(i, 1) 'Date
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
.Range("A1:G1").Value = Array("Line", "Date", "Vch Type", "Vch No.", "Particulars", "Debit", "Credit")
.Range("A2").Resize(j, 7).Value = b
.Range("A" & j + 3).Resize(k, 7).Value = c
.Columns("F:G").NumberFormat = "0.00"
'
.Range("A" & j + 3).Resize(k, 7).Interior.Pattern = xlSolid
'
.UsedRange.EntireColumn.AutoFit
.UsedRange.HorizontalAlignment = xlLeft
'
.Range("B:B").NumberFormat = "dd-mm-yyyy"
'
.UsedRange.Interior.Pattern = xlNone
End With
'
NewName = Sheets("Original").Range("K1")
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
VchNo = VchNo + 1
cell.Value = VchNo
End If
'
If cell.Offset(0, 1) = "(as per details)" Then cell.Offset(0, 1).Value = NewName
Next
'
Set rngReferenceRange = Sheets("Bank").Range("A1").CurrentRegion
Set rngToCopy = Sheets("Bank").Cells(rngReferenceRange.Rows.Count + 2, 1).CurrentRegion
'
rngToCopy.Copy
'
'---------------------------------------------------------------------------------------------------------------------
'
With Sheets("A")
.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
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"
.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
'
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:BD3").Resize(Mx).Value ' Probably should make variable for 'BD' ;)
'
.UsedRange.Value = .UsedRange.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:G2000")
''' .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.Calculation = xlAutomatic
Application.ScreenUpdating = True
'
MsgBox ("File sorted successfully.")
End Sub
drive.google.com
