Copying data from one table into another worksheet

[kiwikiki718]

Hi all, I am trying to copy data from one worksheet into another worksheet displaying the status along with the month and score for each status. the code below works just for the for status (High 1) I was wondering how I could continue displaying the results for all the status without having to manually write out each cell. below is a sample table I am working with along with how I want the data to be copied over to sheet 2

sheet 1

sheet 2 ( copying values from sheet 1) how I want the data to display

Sub CopyValues()
   Dim ws1 As Worksheet
   Dim ws2 As Worksheet
   Dim lastRow As Long

   ' Set references to Worksheet 1 and Worksheet 2
   Set ws1 = ThisWorkbook.Worksheets("Sheet1")
   Set ws2 = ThisWorkbook.Worksheets("Sheet2")

   ' Copy values from Worksheet 1 to Worksheet 2
   ws2.Range("A2").Value = ws1.Range("A2").Value ' Copy value from A2 to A2
   ws2.Range("B2").Value = ws1.Range("B1").Value ' Copy value from D1 to B2
   ws2.Range("C2").Value = ws1.Range("B2").Value ' Copy value from D2 to D2

   ' Find the next empty row in column A of Worksheet 2
   lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
   lastRow = IIf(lastRow < 2, 2, lastRow + 1) ' Ensure the minimum starting row is 2

  
   ws2.Range("A" & lastRow).Value = ws1.Range("A2").Value
   ws2.Range("B" & lastRow).Value = ws1.Range("C1").Value
   ws2.Range("C" & lastRow).Value = ws1.Range("C2").Value

 
   lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
   lastRow = IIf(lastRow < 2, 2, lastRow + 1)
 
   ws2.Range("A" & lastRow).Value = ws1.Range("A2").Value
   ws2.Range("B" & lastRow).Value = ws1.Range("D1").Value
   ws2.Range("C" & lastRow).Value = ws1.Range("D2").Value
 
  
   lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
   lastRow = IIf(lastRow < 2, 2, lastRow + 1)
 
   ws2.Range("A" & lastRow).Value = ws1.Range("A2").Value
   ws2.Range("B" & lastRow).Value = ws1.Range("E1").Value
   ws2.Range("C" & lastRow).Value = ws1.Range("E2").Value
 
 
   lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
   lastRow = IIf(lastRow < 2, 2, lastRow + 1)
 
   ws2.Range("A" & lastRow).Value = ws1.Range("A2").Value
   ws2.Range("B" & lastRow).Value = ws1.Range("F1").Value
   ws2.Range("C" & lastRow).Value = ws1.Range("F2").Value
 
  
   lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
   lastRow = IIf(lastRow < 2, 2, lastRow + 1)
 
   ws2.Range("A" & lastRow).Value = ws1.Range("A2").Value
   ws2.Range("B" & lastRow).Value = ws1.Range("G1").Value
   ws2.Range("C" & lastRow).Value = ws1.Range("G2").Value
 
  
   lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
   lastRow = IIf(lastRow < 2, 2, lastRow + 1)
 
   ws2.Range("A" & lastRow).Value = ws1.Range("A2").Value
   ws2.Range("B" & lastRow).Value = ws1.Range("H1").Value
   ws2.Range("C" & lastRow).Value = ws1.Range("H2").Value
End Sub

 

[kevin9999]

Please try the following on a copy of your workbook.

Option Explicit
Sub kiwikiki()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")          '<~~ *** amend sheet names as required ***
    Set ws2 = Worksheets("Sheet2")
    
    With ws2
        .Range("A:C").ClearContents
        .Range("A1:C1").Value = Array("Status", "Month", "Score")
    End With
    
    Dim a, b, c
    Dim i As Long, j As Long, k As Long
    a = ws1.Range(ws1.Cells(2, 1), ws1.Cells(Cells(Rows.Count, 1).End(xlUp).Row, ws1.Cells(1, Columns.Count).End(xlToLeft).Column))
    b = Application.Transpose(ws1.Range(ws1.Cells(1, 2), ws1.Cells(1, ws1.Cells(1, Columns.Count).End(xlToLeft).Column)))
    ReDim c(1 To (UBound(a, 1) * UBound(b, 1)), 1 To 3)
    k = 1
    For i = 1 To UBound(a, 1)
        For j = 1 To UBound(b, 1)
            c(k, 1) = a(i, 1): c(k, 2) = b(j, 1): c(k, 3) = a(i, j + 1)
            k = k + 1
        Next j
    Next i
    
    ws2.Range("A2").Resize(UBound(c, 1), 3).Value = c
End Sub

 

[Herakles]

Amend sheet names as appropriate.

Public Sub kiwikiki718()
Dim rng As Range
Dim ws1 As Worksheet
    
    Set ws1 = Worksheets("Sheet1")
    
    With Worksheets("Sheet2")
        .Cells.Clear
        .Range("A1:C1").Value = Array("Status", "Month", "Score")
        For Each rng In ws1.Range("B2").Resize(ws1.Cells(Rows.Count, 1).End(xlUp).Row - 1, _
            ws1.Cells(1, Columns.Count).End(xlToLeft).Column - 1).Cells
                .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(1, 3).Value = _
                    Array(ws1.Cells(rng.Row, 1).Value, ws1.Cells(1, rng.Column).Value, rng.Value)
        Next rng
    End With
    
End Sub