Macro to move some data from a grid layout to a list

[tonywatsonhelp]

Hi Everyone,

I have my data in a grid layout

So Sheet"Data"
goes like this

Column A, is Date
Column D, is Company
Columns E to BB are sales person and commision
So E would be "Dave" F would Be "£100" G would be "Simon" H would be "£200" and so on with sales person and commision next to each other
So Heres what i need

To filter the data to show only the date 07/12/2018 (i will chnge this as i need to but that date is the first one i need)
then starting at columns E & F look to see if F is greater than zero (basicly some of these columns will have zeros in them and I want to miss them out)
if it is Copy that ror (values only) Column A to Sheet "Money Owed" find first row with no data in column A and paste,
Column D to B and Columns E & F to C & D
then do the same with G&H and so on.

Please help if you can

Thanks

Tony

 

[mumps]

Try this macro. It prompts you to enter a date.

Sub MoveData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, dDate As Date, x As Long, y As Long, z As Long, lCol As Long, lrow As Long
    z = 2
    lrow = 2
    lCol = Cells(2, Columns.Count).End(xlToLeft).Column
    dDate = InputBox("Please enter a date using format: yyyy/mm/dd", , Format(Date, "yyyy-mm-dd"))
    If Len(dDate) = 0 Then
        MsgBox ("You have not entered a date.")
        Exit Sub
    End If
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Range("A1:A" & LastRow).AutoFilter Field:=1, Criteria1:=dDate
    Intersect(Rows("2:" & LastRow), Range("A:A,D:D").SpecialCells(xlCellTypeVisible)).Copy Sheets("Money Owed").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    For Each Rng In Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
        x = Rng.Row
        For y = 5 To lCol Step 2
            lcol2 = Sheets("Money Owed").Cells(lrow, Columns.Count).End(xlToLeft).Column + 1
            If Cells(x, y + 1) > 0 Then
                Cells(x, y).Resize(1, 2).Copy Sheets("Money Owed").Cells(z, lcol2)
            End If
        Next y
        z = z + 1
        lrow = lrow + 1
    Next Rng
    Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub