need macro

[FrankSit]

Hello, Anybody can help me on how to make a macro to modify the lay out of my worksheet as shown in Sheet1, to be like the one shown in "To be" sheet. This is the format of report from a database that can be
copied to clip board in excel. Each person has multifield downward, and each group has a blank row cell in excel. In "to be", I want the period total to the line of the name. So that I can use vlookup each person's donation for 2023 compared with 2024

Thank you for any help

Frank

 

[FrankSit]

Sorry, the image should be this:

 

[Fuji]

try

Sub test()
    Dim a, x
    Sheets("to be").[a1].CurrentRegion.ClearContents
    With Sheets("sheet1")
        With .Range("a1", .Range("a" & Rows.Count).End(xlUp)(1, 6))
            x = Filter(.Parent.Evaluate(Replace("transpose(if(#<>"""",row(#)))", "#", .Columns(6).Address)), False, 0)
            If UBound(x) < 0 Then MsgBox "No data to be Exit Sub"
            a = Application.Index(.Value, Application.Transpose(x), [{1,6}])
        End With
    End With
    Sheets("to be").Cells(1).Resize(UBound(a, 1), 2) = a
End Sub

 

[Fuji]

Ignore above due to data layouts I made was wrong...

Sub test()
    Dim x, y, i&
    Sheets("to be").[a1].CurrentRegion.ClearContents
    With Sheets("sheet1")
        x = Filter(.[transpose(if(a1:a50000<>"",row(1:50000)))], False, 0)
        y = Filter(.[transpose(if(f1:f50000<>"",row(1:50000)))], False, 0)
        If (UBound(x) < 1) + (UBound(y) < 1) Then Exit Sub
        If UBound(x) <> UBound(y) Then Exit Sub
        ReDim a(1 To UBound(x) + 1, 1 To 2)
        For i = 0 To UBound(x)
            a(i + 1, 1) = .Cells(x(i), "a")
            a(i + 1, 2) = .Cells(y(i), "f")
        Next
    End With
    Sheets("to be").Cells(1).Resize(UBound(a, 1), 2) = a
End Sub

 

[Peter_SSs]

Welcome to the MrExcel board!

For the future, I suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with.
(If you have trouble with XL2BB, review the "XL2BB Icons greyed out" link in the 'Known XL2BB issues' section near the top of the XL2BB Instructions page linked above.)

Anybody can help me on how to make a macro

Do you really need a macro?

FrankSit.xlsm
	A	B	C	D	E	F
1	Donor Name					Period Total
2	Mr. A	date	info	amount	subtotal	53.00
3
4	Mr.B	date	info	amount
5			info	amount
6			info	amount
7			info	amount
8			info	amount
9			info	amount	subtotal
10		date	info	amount
11			info	amount	subtotal
12		date	info	amount
13			info	amount
14			info	amount	subtotal
15		date	info	amount
16			info	amount
17			info	amount	subtotal
18		date	info	amount
19			info	amount	subtotal
20		date	info	amount
21			info	amount
22			info	amount
23			info	amount	subtotal	13,282.00
24
25	MR.C	date	info	amount	subtotal	1,500.00
Sheet1

Instead, could you use a couple of filter formulas like I have in columns A & B below and then do your lookups like the examples in columns E:F?

FrankSit.xlsm
	A	B	C	D	E	F
1	Donor Name	Period Total			Lookup Name	Amount
2	Mr. A	53.00			Mr.B	13,282.00
3	Mr.B	13,282.00			Mr.Z	none
4	MR.C	1,500.00			Mr. A	53.00
5
6
To be

Cell Formulas
Range	Formula
A1:A4	A1	=FILTER(Sheet1!A1:A1000,Sheet1!A1:A1000<>"")
B1:B4	B1	=FILTER(Sheet1!F1:F1000,Sheet1!F1:F1000<>"")
F2:F4	F2	=XLOOKUP(E2:E4,A1#,B1#,"none")
Dynamic array formulas.

 

[FrankSit]

Ignore above due to data layouts I made was wrong...

Sub test()
    Dim x, y, i&
    Sheets("to be").[a1].CurrentRegion.ClearContents
    With Sheets("sheet1")
        x = Filter(.[transpose(if(a1:a50000<>"",row(1:50000)))], False, 0)
        y = Filter(.[transpose(if(f1:f50000<>"",row(1:50000)))], False, 0)
        If (UBound(x) < 1) + (UBound(y) < 1) Then Exit Sub
        If UBound(x) <> UBound(y) Then Exit Sub
        ReDim a(1 To UBound(x) + 1, 1 To 2)
        For i = 0 To UBound(x)
            a(i + 1, 1) = .Cells(x(i), "a")
            a(i + 1, 2) = .Cells(y(i), "f")
        Next
    End With
    Sheets("to be").Cells(1).Resize(UBound(a, 1), 2) = a
End Sub

Thank you Fuji, I will try the codes. Can I put the macro in another sheets with a button to run the macro?. I will let you know if it can work for me.

God bless!

Frank

 

[FrankSit]

Do you really need a macro?

Yes Peter, so that anytime the data impoted from the database, we do not have to chane the filter range.

Thank you,

Frank

 

[Peter_SSs]

Yes Peter, so that anytime the data impoted from the database, we do not have to chane the filter range.

Not sure exactly how you are getting rid of the old data and inserting the new data but depending on that method, if you make the range big enough to start with to be bigger than any amount of data you are ever likely to have you would never need to change the filter range? For example, if your data is typically tens of thousands of rows, change where I have 1000 to say 200000 and it would always be big enough.

If you really do want a macro then try this after checking/editing sheet names.

Sub Donations()
  Sheets("Sheet1").Range("A:A,F:F").Copy Sheets("To be").Range("A1")
  Sheets("To be").Columns("A:B").SpecialCells(xlBlanks).Delete Shift:=xlUp
End Sub

 

[FrankSit]

Ignore above due to data layouts I made was wrong...

Sub test()
    Dim x, y, i&
    Sheets("to be").[a1].CurrentRegion.ClearContents
    With Sheets("sheet1")
        x = Filter(.[transpose(if(a1:a50000<>"",row(1:50000)))], False, 0)
        y = Filter(.[transpose(if(f1:f50000<>"",row(1:50000)))], False, 0)
        If (UBound(x) < 1) + (UBound(y) < 1) Then Exit Sub
        If UBound(x) <> UBound(y) Then Exit Sub
        ReDim a(1 To UBound(x) + 1, 1 To 2)
        For i = 0 To UBound(x)
            a(i + 1, 1) = .Cells(x(i), "a")
            a(i + 1, 2) = .Cells(y(i), "f")
        Next
    End With
    Sheets("to be").Cells(1).Resize(UBound(a, 1), 2) = a
End Sub

Thank you very much Fuji, it works for me. My question is if the number of row is more than 50000, I just change the a50000?.

Thank you,

Frank

 

[Peter_SSs]

Did you try the other simple macro suggestion? (Already deals with any number of rows & clearing out any previous data.)