create report from text in spreadsheet

[cmccabe1]

I am trying to create a reporting macro to place in the Quick Access Toolbar, but recording doesn't seem to change each new sample as the new one gets replaced with the sample that the record was used on. I have attached an xlsx showing the data is looks and the desired report after. Previously I had no trouble but something appears to be different now. The box towards the end can be variable as sometimes there are 3 rows and sometimes there are 10. I have have attached an example file with the the data tab being the initial and the desired being the final report. All the information is used for the report is in the data it is basically just re-ordering, but it doesn't seem to be working. Thank you .

[Bob Phillips]

Public Sub FormatData()
Dim cell As Range
Dim lastrow As Long
Dim findrow As Long
Dim numrows As Long
Dim i As Long

    Application.ScreenUpdating = False

    Worksheets("Data").Rows(1).Insert
    
    Call CopyData(Worksheets("Data"), "#Display Name =", Worksheets("Sheet1").Range("A1"))
    Call CopyData(Worksheets("Data"), "#Sample =", Worksheets("Sheet1").Range("A2"))
    Call CopyData(Worksheets("Data"), "#Medical Record =", Worksheets("Sheet1").Range("A3"))
    Call CopyData(Worksheets("Data"), "#Date of Birth =", Worksheets("Sheet1").Range("A4"))
    Call CopyData(Worksheets("Data"), "#Order Date =", Worksheets("Sheet1").Range("A5"))
    Call CopyData(Worksheets("Data"), "#Gender =", Worksheets("Sheet1").Range("A6"))
    Call CopyData(Worksheets("Data"), "#Build =", Worksheets("Sheet1").Range("A7"))
    Call CopyData(Worksheets("Data"), "#SpikeIn =", Worksheets("Sheet1").Range("A8"))
    Call CopyData(Worksheets("Data"), "#Location =", Worksheets("Sheet1").Range("A9"))
    Call CopyData(Worksheets("Data"), "#Control Gender =", Worksheets("Sheet1").Range("A10"))
    Call CopyData(Worksheets("Data"), "#Quality =", Worksheets("Sheet1").Range("A11"))
    findrow = CopyData(Worksheets("Data"), "Chromosome Region", Nothing)
    With Worksheets("Data")
    
        lastrow = .Cells(findrow, "A").End(xlDown).Row
        numrows = lastrow - findrow + 1
        .Rows(findrow).Resize(numrows).Copy Worksheets("Sheet1").Range("A12")
    End With
    With Worksheets("Sheet1").Range("A12").Resize(numrows, 7)
    
                 
        .BorderAround LineStyle:=xlContinuous, ColorIndex:=0, Weight:=xlThin
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .Weight = xlThin
        End With
    End With

    Worksheets("Data").Rows(1).Delete
    
    Application.ScreenUpdating = True
    
End Sub

Private Function CopyData( _
    ByRef From As Worksheet, _
    ByVal LookFor As String, _
    Optional ByRef Target As Range) As Long
Dim cell As Range
    
    With From
    
        Set cell = .Cells.Find(What:=LookFor, _
                               After:=.Range("A1"), _
                               LookIn:=xlFormulas, _
                               LookAt:=xlPart, _
                               SearchOrder:=xlByRows, _
                               SearchDirection:=xlNext, _
                               MatchCase:=False, _
                               SearchFormat:=False)
        If Not Target Is Nothing Then
        
            cell.Copy Target
            Target.Value = Right$(Target.Value, Len(Target.Value) - 1)
        End If
        
        CopyData = cell.Row
    End With
End Function

[snb]

I came up with:

Sub M_snb()
   sn = Sheets("Data").Cells(1).CurrentRegion
   
   sq = Split("Name_SampleCode_Medical Record_Date of Birth_Order Date_Gender_Build_SpikeIn_Location_Control Gender_QC", "_")
   c00 = "Display Name_Sample_Medical Record_Date of Birth_Order Date_Gender_Build_SpikeIn_Location_Control Gender_Quality"
   st = Split(c00, "_")
   
   ReDim sp(10, 0)
   For j = 1 To UBound(sn)
      If Left(sn(j, 1), 1) <> "#" Then Exit For
      sz = Split(sn(j, 1), "=")
      c01 = Mid(Trim(sz(0)), 2)
      If InStr(c00, c01) Then
            y = Application.Match(c01, st, 0) - 1
            sp(y, 0) = sq(y) & " =" & sz(1)
      End If
   Next
      
   Sheet2.Cells(30, 1).Resize(11) = sp
   Sheet2.Cells(41, 1).Resize(UBound(sn) - j + 1, UBound(sn, 2)) = Application.Index(sn, Evaluate("row(" & j & ":" & UBound(sn) & ")"), Array(1, 2, 3, 4, 5, 6, 7))
End Sub