opying into cells if particular criteria is met

Mazbuka

New Member
I have an excel journal template that I want completed from a cashbook type source...I'll show a simple example:

Say this is my cashbook



A B C D
1 DATE DETAIL AMOUNT CASH/CHECK
2 17-10-19 John 1000 CASH
3 17-10-19 Joan 1200 CASH
4 17-10-19 Fred 1500 CHECK
5 17-10-19 Pat 800 CASH
6 17-10-19 Mary 900 CHECK
7 17-10-19 Steve 750 CASH

<colgroup><col span="4"><col><col span="3"><col></colgroup><tbody>
</tbody>

<colgroup><col span="4"><col><col span="3"><col></colgroup><tbody>
</tbody>
I need relevant cells copied into the cash journal below

If D2 above = "cash", copy A2, B2, C2 & D2 above into A2, C2, D2 & E2 below respectively.

However if D2 above = "check" then Look at D3 above, if that's = "cash" copy from row 3 above into row 2 below, if it's ="check" then disregard and look at D4 & so on.

End result will look like this.


A B C C D E
1 DATE REFERENCE DETAIL DOC NUM AMOUNT CASH/CHECK
217-10-19OTHER FIXED DATAJohn OTHER FIXED DATA 1000 CASH
3 17-10-19 OTHER FIXED DATA Joan OTHER FIXED DATA 1200 CASH
4 17-10-19 OTHER FIXED DATA Pat OTHER FIXED DATA 800 CASH
5 17-10-19 OTHER FIXED DATA Steve OTHER FIXED DATA 750 CASH

<colgroup><col><col><col><col><col><col><col><col><col><col><col span="2"><col></colgroup><tbody>
</tbody>

<colgroup><col span="12"><col></colgroup><tbody>
</tbody>
 

mumps

Well-known Member
Assuming your cashbook and cash journal are in two separate sheets in the same workbook and are named "Cashbook" and "Cash Journal" respectively, try this macro:
Code:
Sub copyData()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWS As Worksheet
    Set srcWS = ThisWorkbook.Sheets("Cashbook")
    Set desWS = ThisWorkbook.Sheets("Cash Journal")
    Dim LastRow As Long, header As Range, fnd As Range
    LastRow = srcWS.Range("A" & srcWS.Rows.Count).End(xlUp).Row
    With srcWS.Cells(1, 1).CurrentRegion
        .AutoFilter 4, "CASH"
        With srcWS
            For Each header In .Range("A1:D1")
                Set fnd = desWS.Rows(1).Find(header, LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    .Cells(2, header.Column).Resize(LastRow - 1).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(desWS.Rows.Count, fnd.Column).End(xlUp).Offset(1, 0)
                End If
            Next header
        End With
    End With
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub
 
Last edited:

Mazbuka

New Member
Assuming your cashbook and cash journal are in two separate sheets in the same workbook and are named "Cashbook" and "Cash Journal" respectively, try this macro:
Code:
Sub copyData()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWS As Worksheet
    Set srcWS = ThisWorkbook.Sheets("Cashbook")
    Set desWS = ThisWorkbook.Sheets("Cash Journal")
    Dim LastRow As Long, header As Range, fnd As Range
    LastRow = srcWS.Range("A" & srcWS.Rows.Count).End(xlUp).Row
    With srcWS.Cells(1, 1).CurrentRegion
        .AutoFilter 4, "CASH"
        With srcWS
            For Each header In .Range("A1:D1")
                Set fnd = desWS.Rows(1).Find(header, LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    .Cells(2, header.Column).Resize(LastRow - 1).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(desWS.Rows.Count, fnd.Column).End(xlUp).Offset(1, 0)
                End If
            Next header
        End With
    End With
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Thanks very much...I'll play around with this get an understanding of it.
 

Some videos you may like

This Week's Hot Topics

Top