PDA

View Full Version : [SOLVED] Format data in Excel with subtotal



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

YOYO
09-13-2017, 12:45 PM
Any helps with this ?

mdmackillop
09-13-2017, 12:53 PM
No idea what you're trying to do.

YOYO
09-13-2017, 01:38 PM
Hi Mdmackillop,

can you open the attachment? if you could open the attachment, the top part is what raw data look like and bottom will be after formatting.
the code is what i am using for current, but to formatted the way i want, need make some changes to the current code.

Thank you,
let me know if you can see attachment, or i can re-post this questions.

mdmackillop
09-13-2017, 02:13 PM
What is the "rule" for splitting into 2 tables as shown?

YOYO
09-14-2017, 07:05 AM
Hey, so it wont splitting into 2 tables, its will just formatted it on same tab (dont need create new tabs for formatted data)
when we run the macro, the raw data will show as formatted.

I am not sure if you know what i am saying, i feel like its not easy to explain. but plz let me know if you have questions about my post.
Thanks a lot!!!!!

mdmackillop
09-14-2017, 07:34 AM
Book transfer is totalled separately, will anything else go to the lower total? If so, how is it defined?
Book Transfer shows AMEX in column C; why?
Are there other bank name abbreviations such as AMEX. Have you a table of bank names which can be referred to?
Are "x x x x x x" numbers or text?

YOYO
09-14-2017, 11:58 AM
Yes, so if there is "book transfer debit a/c" will subtotaled separately from top. won't be anything else go to the lower total.

thats a typo, i am sorry. it should show " book transfer debit" in column c

basically, every month pretty much the same, there will be "BOA", "PAYMENTECH" AND "AMEX", sometimes has "book transfer debit a/c", not all the time.

"******x" are numbers, ":", text, and space. mixing together.

Thank you!!!!!!

mdmackillop
09-14-2017, 02:25 PM
Sub Test()

Application.CutCopyMode = False
Set dic = CreateObject("Scripting.Dictionary")
dic.Add "BOA", "BOA"
dic.Add "CITI", "CITI"
dic.Add "AMERICAN EXPRESS", "AMEX"
dic.Add "PAYMENTECH", "PAYMENTECH"


Range("D:E").Delete
Range("C:C").Insert
Range("C:C").ColumnWidth = 20


Set tt = Columns(1).Find("Total transfer", lookat:=xlPart)
Set dt = Columns(1).Find("DATE", lookat:=xlPart)


Set c = Columns(2).Find("BOOK TRANSFER", lookat:=xlPart)
If Not c Is Nothing Then
c.Offset(, -1).Resize(, 4).Copy Cells(tt.Row + 3, 1)
c.Offset(, -1).Resize(, 4).Delete shift:=xlUp
With Cells(tt.Row + 2, 1).Resize(, 4)
.Value = Array("Date", "DESCRIPTION", "DEBIT", "AMOUNT")
.Font.Bold = True
.Borders(xlBottom).LineStyle = xlContinuous
End With
Set CEL = Cells(tt.Row + 2, 1).End(xlDown)(2)
With CEL.Resize(, 4)
.Value = Array("Subtotal", "", "DEBIT", "")
.Font.Bold = True
End With
With CEL.Offset(, 3)
.FormulaR1C1 = "=R[-1]C"
.Borders(8).LineStyle = xlContinuous
.Borders(9).LineStyle = xlDouble
End With
End If


tt.Resize(, 4).ClearContents

With Cells(dt.Row, 1).Resize(, 4)
.Value = Array("Date", "DESCRIPTION", "DEBIT", "AMOUNT")
.Font.Bold = True
.Borders(xlBottom).LineStyle = xlContinuous
End With
Set CEL = Cells(dt.Row, 1).End(xlDown)(2)
With CEL.Resize(, 4)
.Value = Array("Subtotal", "", "DEBIT", "")
.Font.Bold = True
End With
Rws = dt.Row - CEL.Row + 1
With CEL.Offset(, 3)
.NumberFormat = "0.00"
.FormulaR1C1 = "=SUM(R[" & Rws & "]C:R[-1]C)"
.Borders(8).LineStyle = xlContinuous
.Borders(9).LineStyle = xlDouble
End With


For Each d In dic.keys
Set c = Columns(2).Find(d, lookat:=xlPart)
If Not c Is Nothing Then
c.Value = Split(c, d)(0) & d
c.Offset(, 1).Value = dic(d)
End If
Next
End Sub

YOYO
09-22-2017, 11:28 AM
Hi Master!!, sorry to get back to late, I am trying your code now, but i got the error says :

Run-time error '91': Object variable or with block variable not set

after i click debug, the part shows below is highlighted.

c.Offset(, -1).Resize(, 4).Copy Cells(tt.Row + 3, 1)

not sure how i can fix this.

if you could help, thanks!!
appreciate your time.

mdmackillop
09-22-2017, 12:34 PM
Can't see the issue

YOYO
10-09-2017, 01:37 PM
Hi Master, how i can reply you with attachment ?

mdmackillop
10-09-2017, 01:49 PM
Go Advanced / Manage Attachments

YOYO
10-09-2017, 02:04 PM
Hi Master, Please see attached, I made some changes. Thanks for your great help!

YOYO
10-09-2017, 02:17 PM
Hi Master, please see #14, i just posted it. If you have time to look at it .
Thanks a lot!

mdmackillop
10-10-2017, 04:09 AM
You already have the solution to the original problem and you've made changes to your data, not to the code. We would expect you to make an effort to resolve this yourself as we cannot keep providing solutions each time new data comes along.
The last section of code does need amending to deal with repeating data, as follows:

For Each d In dic.keys
With Columns(2)
Set c = .Find(d, lookat:=xlPart)
If Not c Is Nothing Then
fa = c.Address
Do
c.Value = Split(c, d)(0) & d
c.Offset(, 1).Value = dic(d)
Set c = .FindNext(c)
Loop Until c.Address = fa
End If
End With
Next