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 http://www.excelforum.com/images/smilies/smile.gif.

[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