Automate Process

[Aviles]

Hi all, I’m looking for some help on automating a process in Excel. I can do simple vba but I’m out of my depth on this one. Here is the process I’m trying to automate:

Sheet “Dates” has a list of unique dates starting in cell A2 down to A250 (although the number of dates can change). Sheet “Pair” has data from cells A4:Y80 with SUMPRODUCT formulas that look up data from another sheet based on the specific date entered in cell A1 of sheets "Pair". Cell A1 is the input cell that drives all the formulas in this sheet.

At the moment, I manually enter each date from the “Dates” sheet, by entering the first date into cell A1 in the “Pair” sheet, I then run a macro that filters this data and copies the simplified results in sheet “Net”. I then copy this data into another sheet “Total” which has a running total of all the data for each date, separated by a blank row.

I then repeat this process for the next date, and so on until I reach the final date. Is there a way to automate this process? Hopefully I have explained this well, please let me know if I can provide more info.

Thanks in advance.

 

[My Aswer Is This]

Would you please show us the script you are now using to copy data from Sheet named "Pair" to sheet named "Net"

And how do you do this:

I then copy this data into another sheet “Total”​

Manually or using a script?

 

[Aviles]

Would you please show us the script you are now using to copy data from Sheet named "Pair" to sheet named "Net"

And how do you do this:

I then copy this data into another sheet “Total”​

Manually or using a script?

Thanks for responding. Copying between sheets is done with this code:

Sheets("Pair").Select
    Range("A5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Selec
    Selection.Copy
    Sheets("Net").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'Deletes rows in column O if cells = "0"
    Dim LR As Long, i1 As Long
    LR = Range("O" & Rows.Count).End(xlUp).Row
    For i1 = LR To 1 Step -1
    If Range("O" & i1).Value = 0 Then Rows(i1).Delete
    Next i1
    
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("Total").Select
    Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveSheet.Paste

The only task that is manual at the moment is when I enter a date in cell A1 of sheet "Pair", which is what I would like to automate.

I was thinking that maybe using a copy and paste loop would work? Starting from cell A2 in the "Dates" sheet, copy the first date and paste into cell A1 of sheet "Pair". Run my existing code which copies to the "Total" sheet and then create a loop which copies the next date in cell A3 ("Dates") until the dates end.

Is something like this is possible?

Thanks.

 

[JackDanIce]

This is a guess but the following:

- Reads all the dates from sheet Dates into an array
- For each loop over the the array, the array element is copied into A1 of sheet Pair
- A different array captures A5 to end point from sheet Pair and copies it into the first empty row (from the bottom) of sheet Net
- When it finishes looping, it replaces all 0 values in sheet Net, column 0 with blanks, then filters for blank values in column 0 and deletes all visible rows (it made sense to do this outside of the loop in a single operation than repeatedly inside the loop for each iteration).
- Finally copies remaining results from Net into Total

Bound to be ambiguity or misunderstanding so not expecting to work first time, test on a copy of your workbook if any concerns, however, try:

Sub Copymove()

    Dim i       As Long
    Dim x       As Long
    Dim y       As Long
    Dim arrd()  As Long
    Dim arr()   As Variant
    
    Application.ScreenUpdating = False
        
    arrd = Sheets("Dates").Cells(1, 1).Resize(Sheets("Dates").Cells(Rows.Count, 1).End(xlUp).Row).Value
    
    If Sheets("Net").AutoFilterMode Then Sheets("Net").AutoFilterMode = False
    
    For i = LBound(arrd, 1) To UBound(arrd, 1)
        With Sheets("Pair")
            .Cells(1, 1).Value = arrd(i, 1)
            x = Application.Max(.Cells(.Rows.Count, 1).End(xlUp).Row, 5)
            y = .Cells(5, .Columns.Count).End(xlToLeft).column
            arr = .Cells(1, 5).Resize(x - 4, y).Value
        End With
        
        Sheets("Net").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        Erase arr
    Next i
    Erase arrd
    
    With Sheets("Net")
        x = .Cells(.Rows.Count, 15).End(xlUp).Row
        With .Cells(1, 15).Resize(x)
            .Replace what:=0, replacement:=vbNullString
            .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End With
        .AutoFilterMode = False
        x = .Cells(.Rows.Count, 1).End(xlUp).Row
        y = .Cells(1, .Columns.Count).End(xlToLeft).column
        arr = .Cells(1, 1).Resize(x, y).Value
    End With
    
    Sheets("Total").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    Erase arr
    
End Sub

 

[Aviles]

Thank you, will give that a try.