Finding a value, then copying and pasting cells around it to another sheet

[cboyce44]

Hello. I am a novice with Excel VBA. I have a certificate excel workbook that contains 34 sheets. So far I have it where the user imports data from a PDF document into a sheet called "PitchGageData". What I'm trying to do is search in the "PitchGageData" tab to look for "L1". Once it finds which cell it is in (depending on the pdf file, it moves around), I then want to copy that cell. I need the "L1", then the 2 values below it. Then I need the same for "L2", "L3", "L4", "L5", and "L6". Below is a screen shot of how the pdf was imported into the sheet.

Once I have copied all the values in the cells, I want to paste them to another worksheet called "Nominal Error Calculations" into cell A60, and look like this:

Thank you for your help. I have spent days trying to figure this out.

 

[Alex Blakenburg]

See if this works for you:

Sub FindAndCopy()

    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim rngSrc As Range, rngDest As Range, rCell As Range
    Dim rowSrc As Long
    Dim colLast As Long
    Dim cntItem As Long
    Dim arrDest As Variant
    Dim i As Long
    
    Set wsSrc = Worksheets("PitchGageData")
    Set wsDest = Worksheets("Nominal Error Calculations")
    Set rngDest = wsDest.Range("A60")
    
    ' Try xlWhole first change to xlPart if required
    Set rngSrc = wsSrc.UsedRange.Find(What:="L1", LookIn:=xlFormulas, LookAt:=xlWhole, _
                                        SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                        MatchCase:=False, SearchFormat:=False)
                                        
    If rngSrc Is Nothing Then Exit Sub
    
    With wsSrc
        colLast = .Cells(rngSrc.Row, Columns.Count).End(xlToLeft).Column
    End With
    
    Set rngSrc = rngSrc.Resize(1, colLast - rngSrc.Column + 1)
    cntItem = WorksheetFunction.CountA(rngSrc)
    
    ReDim arrDest(1 To 3, 1 To cntItem)
    
    For Each rCell In rngSrc
        If rCell <> "" Then
            i = i + 1
            arrDest(1, i) = rCell.Value
            arrDest(2, i) = rCell.Offset(1).Value
            arrDest(3, i) = rCell.Offset(2).Value
        End If
    Next rCell
    
    rngDest.Resize(3, i).Value = arrDest
                    
End Sub

 

[cboyce44]

See if this works for you:

Sub FindAndCopy()

    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim rngSrc As Range, rngDest As Range, rCell As Range
    Dim rowSrc As Long
    Dim colLast As Long
    Dim cntItem As Long
    Dim arrDest As Variant
    Dim i As Long
   
    Set wsSrc = Worksheets("PitchGageData")
    Set wsDest = Worksheets("Nominal Error Calculations")
    Set rngDest = wsDest.Range("A60")
   
    ' Try xlWhole first change to xlPart if required
    Set rngSrc = wsSrc.UsedRange.Find(What:="L1", LookIn:=xlFormulas, LookAt:=xlWhole, _
                                        SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                        MatchCase:=False, SearchFormat:=False)
                                       
    If rngSrc Is Nothing Then Exit Sub
   
    With wsSrc
        colLast = .Cells(rngSrc.Row, Columns.Count).End(xlToLeft).Column
    End With
   
    Set rngSrc = rngSrc.Resize(1, colLast - rngSrc.Column + 1)
    cntItem = WorksheetFunction.CountA(rngSrc)
   
    ReDim arrDest(1 To 3, 1 To cntItem)
   
    For Each rCell In rngSrc
        If rCell <> "" Then
            i = i + 1
            arrDest(1, i) = rCell.Value
            arrDest(2, i) = rCell.Offset(1).Value
            arrDest(3, i) = rCell.Offset(2).Value
        End If
    Next rCell
   
    rngDest.Resize(3, i).Value = arrDest
                   
End Sub

I had to change it to xlPart for anything to work. However, it only brought in this? I tried to figure out how to import just the results I need from the pdf, but I don't know how to do that.

 

[cboyce44]

I had to change it to xlPart for anything to work. However, it only brought in this? I tried to figure out how to import just the results I need from the pdf, but I don't know how to do that.

I think there must be another "L1" before the "L1" I am looking for on the page?

 

[cboyce44]

I had to change it to xlPart for anything to work. However, it only brought in this? I tried to figure out how to import just the results I need from the pdf, but I don't know how to do that.

Thanks! That worked!

 

[cboyce44]

See if this works for you:

Sub FindAndCopy()

    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim rngSrc As Range, rngDest As Range, rCell As Range
    Dim rowSrc As Long
    Dim colLast As Long
    Dim cntItem As Long
    Dim arrDest As Variant
    Dim i As Long
   
    Set wsSrc = Worksheets("PitchGageData")
    Set wsDest = Worksheets("Nominal Error Calculations")
    Set rngDest = wsDest.Range("A60")
   
    ' Try xlWhole first change to xlPart if required
    Set rngSrc = wsSrc.UsedRange.Find(What:="L1", LookIn:=xlFormulas, LookAt:=xlWhole, _
                                        SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                        MatchCase:=False, SearchFormat:=False)
                                       
    If rngSrc Is Nothing Then Exit Sub
   
    With wsSrc
        colLast = .Cells(rngSrc.Row, Columns.Count).End(xlToLeft).Column
    End With
   
    Set rngSrc = rngSrc.Resize(1, colLast - rngSrc.Column + 1)
    cntItem = WorksheetFunction.CountA(rngSrc)
   
    ReDim arrDest(1 To 3, 1 To cntItem)
   
    For Each rCell In rngSrc
        If rCell <> "" Then
            i = i + 1
            arrDest(1, i) = rCell.Value
            arrDest(2, i) = rCell.Offset(1).Value
            arrDest(3, i) = rCell.Offset(2).Value
        End If
    Next rCell
   
    rngDest.Resize(3, i).Value = arrDest
                   
End Sub

Alex. This worked. However sometimes when it transposes the pdf document to excel sheet, it puts "LI" instead of "L1". Is there a way that I can search for "LI" as well as "L1"? Just in case this happens?

 

[Alex Blakenburg]

Sure but is L1 or Ll appearing in multiple places ? Is L2 more reliable ? Is the spacing between L1 and L2 consistent ?

 

[Alex Blakenburg]

Alex. This worked. However sometimes when it transposes the pdf document to excel sheet, it puts "LI" instead of "L1". Is there a way that I can search for "LI" as well as "L1"? Just in case this happens?

LI is probably even more of a risk of appearing multiple times in the data but see if this helps:

Sub FindAndCopy_v02()

    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim rngSrc As Range, rngDest As Range, rCell As Range
    Dim rowSrc As Long
    Dim colLast As Long
    Dim cntItem As Long
    Dim arrDest As Variant
    Dim i As Long
    
    Set wsSrc = Worksheets("PitchGageData")
    Set wsDest = Worksheets("Nominal Error Calculations")
    Set rngDest = wsDest.Range("A60")
    
    ' OP is using xlPart (xlWhole would be safer)
    ' Look for L1
    Set rngSrc = wsSrc.UsedRange.Find(What:="L1", LookIn:=xlFormulas, LookAt:=xlPart, _
                                        SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                        MatchCase:=False, SearchFormat:=False)
                                        
    If rngSrc Is Nothing Then
        ' Try alternative LI - OCR misreading 1
        ' if LI is repeats in Data try xlWhole or go straight to trying L2, L3 etc
        Set rngSrc = wsSrc.UsedRange.Find(What:="LI", LookIn:=xlFormulas, LookAt:=xlPart, _
                                    SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                    MatchCase:=False, SearchFormat:=False)
                                    
        If rngSrc Is Nothing Then
            ' Try L2
            Set rngSrc = wsSrc.UsedRange.Find(What:="L2", LookIn:=xlFormulas, LookAt:=xlPart, _
                            SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                            MatchCase:=False, SearchFormat:=False)
            Set rngSrc = rngSrc.Offset(, -3)
        End If
    End If

    If rngSrc Is Nothing Then Exit Sub
    
    With wsSrc
        colLast = .Cells(rngSrc.Row, Columns.Count).End(xlToLeft).Column
    End With
    
    Set rngSrc = rngSrc.Resize(1, colLast - rngSrc.Column + 1)
    cntItem = WorksheetFunction.CountA(rngSrc)
    
    ReDim arrDest(1 To 3, 1 To cntItem)
    
    For Each rCell In rngSrc
        If rCell <> "" Then
            i = i + 1
            arrDest(1, i) = rCell.Value
            arrDest(2, i) = rCell.Offset(1).Value
            arrDest(3, i) = rCell.Offset(2).Value
        End If
    Next rCell
    
    rngDest.Resize(3, i).Value = arrDest
                    
End Sub

 

[cboyce44]

Yeah. that didn't really work either. What if I searched for "Pitch of pin" then copy paste the values under it? would that be easier? Because I'm looking throughout the document, and there are multiple "L2" values before the one I'm looking for. Here is what the chart looks like that I'm trying to get the values from:

 

[Alex Blakenburg]

That is image is very different to the one in Post #1.
In post #1 I would have looked for something like "mutual difference of diameter".
Also the latest post looks like it has merged cells.

1) Have you tried reading it in using Power Query (Data > From File > From PDF) it may give you a cleaner result
2) If that is not an option we need a representative sample of how the pdf looks once you get it into Excel.
Either copying it here using XL2BB or putting a sample on a share service like google drive, drop box etc.