Automatic copy new rows in sheet. Shooter contest.

[HansO]

Hello,

For my shooter contest I have made an excel for writing down my results. I struggle with adding rows in another sheet of the same workbook.

I start with today (ex. 03-09-2024) and I put my results into set of 10 series (Reeks) each of 5 shots. For every set I compute my points and the percentage.. See screenshot.

Every new contest I change the date and add my new results.
The previous data should be copied in another tab Overview (Overzicht) See my screenshot below

The Header in Row 1 should be fixed and the previous results must shift down into row 4. So the last result comes in row 3.
Can some one help me?
Kind regards,

Hans

 

[NdNoviceHlp]

Hi Hans and Welcome to the Board! If your data is laid out as displayed, this seems to work. Change the sheet name from "Sheet1" to whatever for your data sheet and place this code in the sheet code. Then run the "Test" sub. HTH. Dave

Sub test()
Dim DtVar As Date, PtArr() As Variant, PerArr() As Variant, ColCnt As Integer
Dim PtTot As Double, PerAvg As Double, LRow As Integer, ws As Worksheet
Dim ArrCnt As Integer
'store results
With ThisWorkbook.Sheets("Sheet1")
DtVar = .Range("A" & 1)
PtArr = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(Range("C7:L7").Value))
PtTot = .Range("M" & 7)
PerArr = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(Range("C8:L8").Value))
PerAvg = .Range("M" & 8)
End With

'move results
Set ws = ThisWorkbook.Worksheets("overzicht")
With ws
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If LRow = 1 Then
LRow = 2
End If
.Cells(LRow + 1, "A").Value = DtVar
.Cells(LRow + 1, "B").Value = "# Pt/%"

ColCnt = 3
For ArrCnt = LBound(PtArr) To UBound(PtArr)
.Cells(LRow + 1, ColCnt) = PtArr(ArrCnt)
ColCnt = ColCnt + 1
.Cells(LRow + 1, ColCnt) = PerArr(ArrCnt)
ColCnt = ColCnt + 1
Next ArrCnt

.Cells(LRow + 1, "W").Value = PtTot
.Cells(LRow + 1, "X").Value = PerAvg
End With
End Sub

 

[NoSparks]

Another possibility

Not knowing the sheet name or rows used, I use Double-Click on the date in column "A"
Right click on the tab of the sheet of first picture and select View code
paste this into the editor window that opens.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    
    Dim i As Long, rw As Long, col As Long
    Dim ray(0 To 24)
    
    If Not Intersect(Target, Columns("A")) Is Nothing And IsDate(Target) Then
        ' cancel cell edit mode
        Cancel = True
        ' start loading array
        ray(0) = Target
        ray(1) = "# pt/%"
        ' prep for rest
        rw = Target.Row + 6
        i = 2
        ' loop the cells in the 2 required rows of data
        For col = 3 To 13
            ray(i) = Cells(rw, col)
            i = i + 1
            ray(i) = Cells(rw + 1, col)
            i = i + 1
        Next col
        ' write the array to the other sheet
        With Sheets("overzicht")
            .Rows(3).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
            .Range("A3").Resize(, 24).Value = ray
        End With
        ' message just to know it was done
        MsgBox "Double Click Macro Completed"
    End If
    
End Sub