YOYO
09-01-2017, 07:01 AM
Hi all, Please see attached and code below, Current code works fine for formatting and subtotal all data, but I need the new code to format the data show in attachment.
If anyone know how to fix it please help!!!!!!!!
Thanks a lot!!!!
code:
Sub Format()
Dim c As Range
Dim SrchRng
Worksheets("Sheet1").Activate
Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A65536").End(xlUp))
Do
Set c = SrchRng.Find("Total Transfer", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
Columns("C:C").Insert Shift:=xlToRight
Range("F1") = "=RC[-4]"
Range("C2") = "=IF(MID(RC[-1],FIND("":"",RC[-1])+1,4)=""BOFA"",""BOA"",IF(MID(RC[-1],FIND("":"",RC[-1])+1,4)=""PAYM"",""PAYMENTECH"",""AMEX""))"
Range("F1").AutoFill Destination:=Range("F1:F" & Cells(Rows.Count, "E").End(xlUp).Row)
With Range("C2")
.HorizontalAlignment = xlCenter
.AutoFill Destination:=Range("C2:C" & Cells(Rows.Count, "B").End(xlUp).Row)
End With
Columns("F:G").Select
Range("F3").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("F:F").Select
Range("F1").Activate
Selection.Replace What:=" *", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=" for*", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("B:B").Select
Range("B1").Activate
Selection.Replace What:=" *", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=" for*", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("D:D").Select
Range("D1").Activate
Selection.Style = "Comma"
Columns("A:D").Columns.AutoFit
Range("B1") = "DESCRIPTION"
Range("C1") = "DEBIT"
Range("A1:D1").Font.Underline = xlUnderlineStyleSingleAccounting
Rows("1:1").Font.Bold = True
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(lastrow + 1, 1).Formula = "Subtotal"
With Range("A" & lastrow + 1)
.Font.Bold = True
End With
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
Cells(lastrow + 1, 3).Formula = "EFT DEBIT"
With Range("C" & lastrow + 1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
lastrow = Cells(Rows.Count, 4).End(xlUp).Row
Cells(lastrow + 1, 4).Formula = "=sum(D2:D" & lastrow & ")"
lastrow = Cells(Rows.Count, "D").End(xlUp).Row
With Range("D" & lastrow)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).LineStyle = xlDouble
.Font.Bold = True
End With
Columns("D:D").Select
Range("D1").Activate
Selection.Style = "Comma"
Columns("A:D").Columns.AutoFit
Range("A1:H999999").Activate
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("E:F").EntireColumn.Delete
Rows("1:1").Insert Shift:=xlDown
Range("A1").Select
End Sub
20230
Mod Added Edits:
1. I added CODE tags - please use the [#] icon next time
2. I replaced the emoji with colonD
3. I moved your inline attachment to the bottom to make it more visible
If anyone know how to fix it please help!!!!!!!!
Thanks a lot!!!!
code:
Sub Format()
Dim c As Range
Dim SrchRng
Worksheets("Sheet1").Activate
Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A65536").End(xlUp))
Do
Set c = SrchRng.Find("Total Transfer", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
Columns("C:C").Insert Shift:=xlToRight
Range("F1") = "=RC[-4]"
Range("C2") = "=IF(MID(RC[-1],FIND("":"",RC[-1])+1,4)=""BOFA"",""BOA"",IF(MID(RC[-1],FIND("":"",RC[-1])+1,4)=""PAYM"",""PAYMENTECH"",""AMEX""))"
Range("F1").AutoFill Destination:=Range("F1:F" & Cells(Rows.Count, "E").End(xlUp).Row)
With Range("C2")
.HorizontalAlignment = xlCenter
.AutoFill Destination:=Range("C2:C" & Cells(Rows.Count, "B").End(xlUp).Row)
End With
Columns("F:G").Select
Range("F3").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("F:F").Select
Range("F1").Activate
Selection.Replace What:=" *", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=" for*", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("B:B").Select
Range("B1").Activate
Selection.Replace What:=" *", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=" for*", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("D:D").Select
Range("D1").Activate
Selection.Style = "Comma"
Columns("A:D").Columns.AutoFit
Range("B1") = "DESCRIPTION"
Range("C1") = "DEBIT"
Range("A1:D1").Font.Underline = xlUnderlineStyleSingleAccounting
Rows("1:1").Font.Bold = True
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(lastrow + 1, 1).Formula = "Subtotal"
With Range("A" & lastrow + 1)
.Font.Bold = True
End With
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
Cells(lastrow + 1, 3).Formula = "EFT DEBIT"
With Range("C" & lastrow + 1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
lastrow = Cells(Rows.Count, 4).End(xlUp).Row
Cells(lastrow + 1, 4).Formula = "=sum(D2:D" & lastrow & ")"
lastrow = Cells(Rows.Count, "D").End(xlUp).Row
With Range("D" & lastrow)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).LineStyle = xlDouble
.Font.Bold = True
End With
Columns("D:D").Select
Range("D1").Activate
Selection.Style = "Comma"
Columns("A:D").Columns.AutoFit
Range("A1:H999999").Activate
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("E:F").EntireColumn.Delete
Rows("1:1").Insert Shift:=xlDown
Range("A1").Select
End Sub
20230
Mod Added Edits:
1. I added CODE tags - please use the [#] icon next time
2. I replaced the emoji with colonD
3. I moved your inline attachment to the bottom to make it more visible