Hi..
Here's one way to do it.. string a few Find Next functions together and output values using Offset to sheet2. Then create a new Workbook and copy sheet2 to new workbook and rename the new Workbook and the sheet the data was copied to..
Click the "Go!" button in the attached Workbook...
Private Sub CommandButton1_Click()
Dim NewWkb As Workbook
With Worksheets(1).Range("E1", Range("E" & Rows.Count).End(xlUp))
Set c = .Find("Main Crop", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = c.Offset(0, -1).Value
Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Offset(1).Value = c.Offset(0, 1).Value
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
With Worksheets(1).Range("F1", Range("F" & Rows.Count).End(xlUp))
Set c = .Find("Total Area:", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = c.Offset(0, -4).Value
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
With Worksheets(1).Range("B1", Range("B" & Rows.Count).End(xlUp))
Set c = .Find("Harvest Delivery", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
If c.Offset(, 4).Value <> "" Then
Sheets("Sheet2").Range("D" & Rows.Count).End(xlUp).Offset(1).Value = c.Offset(, 4).Value
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Set NewWkb = Workbooks.Add
ThisWorkbook.Sheets("Sheet2").Copy before:=NewWkb.Sheets(1)
NewWkb.Sheets(1).Name = "Exported Report"
NewWkb.Sheets("Exported Report").Cells.Font.ColorIndex = 0
ActiveWorkbook.SaveAs "Report.xls", 56
ThisWorkbook.Sheets("Sheet2").Range("A1").CurrentRegion.Offset(1).ClearContents
End Sub
I didn't get a Harvest Delivery value for:
Chilis : P9 Jalapeno (B 0.31 Ha) 0.31 30000
As in the sample you provided .. it did not exist...
Bookmarks