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

 

[HansO]

Hello NdNoviceHlp,
thx to you both for the VBA routines. I've started withe first VBA and it looks great. except I would rather that the last newest date is always displayed on top in row 3. Is that possible?
The P22 page

The result page (Overzicht)
Is there also a way to count in every contest the numbers eq. 10, 9, 8, etc for that particular day?

Kind regards,

Hans

 

[NdNoviceHlp]

Hi again Hans. This seems to do what you want. 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, Rng As Range, PtRng As Range
'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)
Set PtRng = Range("C2:L6")
End With

'move results
Set ws = ThisWorkbook.Worksheets("overzicht")
With ws
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'move stored results down
If LRow >= 3 Then
Set Rng = .Range(.Cells(3, "A"), .Cells(LRow, "AK"))
.Range("A4").Resize(Rng.Rows.Count, _
                       Rng.Columns.Count).Cells.Value = Rng.Cells.Value
End If
'results to row 3
.Cells(3, "A").Value = DtVar
.Cells(3, "B").Value = "# Pt/%"
ColCnt = 3
For ArrCnt = LBound(PtArr) To UBound(PtArr)
.Cells(3, ColCnt) = PtArr(ArrCnt)
ColCnt = ColCnt + 1
.Cells(3, ColCnt) = PerArr(ArrCnt)
ColCnt = ColCnt + 1
Next ArrCnt

.Cells(3, "W").Value = PtTot
.Cells(3, "X").Value = PerAvg
'total of pts
.Cells(3, "Z").Value = CountNum(PtRng, 11)
.Cells(3, "AA").Value = CountNum(PtRng, 10)
.Cells(3, "AB").Value = CountNum(PtRng, 9)
.Cells(3, "AC").Value = CountNum(PtRng, 8)
.Cells(3, "AD").Value = CountNum(PtRng, 7)
.Cells(3, "AE").Value = CountNum(PtRng, 6)
.Cells(3, "AF").Value = CountNum(PtRng, 5)
.Cells(3, "AG").Value = CountNum(PtRng, 4)
.Cells(3, "AH").Value = CountNum(PtRng, 3)
.Cells(3, "AI").Value = CountNum(PtRng, 2)
.Cells(3, "AJ").Value = CountNum(PtRng, 1)
.Cells(3, "AK").Value = CountNum(PtRng, 0)
End With
End Sub

Function CountNum(Rng As Range, Num As Integer) As Integer
CountNum = Application.WorksheetFunction.CountIf(Rng, Num)
End Function

 

[HansO]

Hello Dave,
it's working, thx.
A last issue: Is it possible after fill in all the shooting values with a button (eq. Transfer) on sheet P22 to transfer automatic all values to the sheet "Overzicht" w/o going too the Developer tab and click Run?
Kind regards
Hans

 

[NdNoviceHlp]

Hans you don't have to go to the developer tab to "Run" the macro. If you're using a button (eg. Transfer) to fill in the values via VBA code, at the end of the button code, add this code to run the test macro. HTH. Dave

Call Test

 

[HansO]

Dave, it works, THX. Kind regards Hans

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Have a nice day. Dave