Copying the value of cell next to a found string in multiple workbooks and pasting it into a new workbook

[frostedzeo]

I have a folder filled with a lot of excel folders that are all formatted slightly differently. I have to find the "part number" in each and copy and paste the value that's next to them into a new excel sheet. Part number also needs to be case insensitive because sometimes it's all caps, just first letter, and all undercase. I've tried a few things, but I've not really gotten close. The closest I think I've been is this code I found from here: It did nothing when I ran it though.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    Dim wOut As Worksheet
    Dim wks As Worksheet
    Dim rFound As Range
    Dim strFirstAddress As String
    Dim strSearch As String
    Const strPath As String = "C:\Searchfolderhere\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir(".xlsx")
    strSearch = InputBox("Please enter the Search Term.")
    Set wOut = Worksheets.Add
    wOut.Range("A1:D1") = Array("Workbook", "Worksheet", "Cell", "Text in Cell")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            For Each wks In .Sheets
                Set rFound = wks.Range("A:A").Find(strSearch, LookIn:=xlValues, lookat:=xlWhole)
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                    Do
                        wOut.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = wkbSource.Name
                        wOut.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = wks.Name
                        wOut.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = rFound.Address
                        wOut.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) = rFound.Value
                        wks.Range(Cells(rFound.Row, 5), Cells(Cells(rFound.Row, Columns.Count).End(xlToLeft).Column)).Copy wOut.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
                        Set rFound = wks.Range("A:A").FindNext(rFound)
                    Loop While rFound.Address <> strFirstAddress
                    sAddr = ""
                End If
            Next wks
        End With
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[dmt32]

Hi welcome to forum

Untested but see if this update to your code will help you

Sub CopyRange()
    Dim wkbDest         As Workbook, wkbSource As Workbook
    Dim wOut            As Worksheet, wks As Worksheet
    Dim strFirstAddress As String, strSearch As String
    Dim strFileName     As String
    Dim rFound          As Range
   
    Const strPath   As String = "C:\Searchfolderhere\"        'change folder path to suit your needs
   
    Do
        strSearch = InputBox("Please enter the Search Term.", "Search")
        'cancel pressed
        If StrPtr(strSearch) = 0 Then Exit Sub
    Loop Until Len(strSearch) > 0
   
    Application.ScreenUpdating = False
   
    Set wkbDest = ThisWorkbook
   
    Set wOut = wkbDest.Worksheets.Add
   
    wOut.Range("A1:D1") = Array("Workbook", "Worksheet", "Cell", "Text in Cell")
   
    strFileName = Dir(strPath & "\" & "*.xlsx", vbDirectory)
   
    'Loop through all Files in path
    Do While Len(strFileName) > 0
   
        Set wkbSource = Workbooks.Open(strPath & strFileName, 0, True)
       
        For Each wks In wkbSource.Worksheets
            Set rFound = wks.Range("A:A").Find(strSearch, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
            If Not rFound Is Nothing Then
                strFirstAddress = rFound.Address
                Do
                   
                    wOut.Cells(wOut.Cells(wOut.Rows.Count, "A").End(xlUp).Row + 1, 1).Resize(1, 4).Value = _
                    Array(wkbSource.Name, wks.Name, rFound.Address, rFound.Value)
                   
                    Set rFound = wks.Range("A:A").FindNext(rFound)
                Loop While rFound.Address <> strFirstAddress
            End If
            Set rFound = Nothing
        Next wks
       
        wkbSource.Close False
        Set wkbSource = Nothing
        strFileName = Dir
    Loop
   
    Application.ScreenUpdating = True
End Sub

Dave

 

[frostedzeo]

Hi welcome to forum

Untested but see if this update to your code will help you

Sub CopyRange()
    Dim wkbDest         As Workbook, wkbSource As Workbook
    Dim wOut            As Worksheet, wks As Worksheet
    Dim strFirstAddress As String, strSearch As String
    Dim strFileName     As String
    Dim LastRow         As Long
    Dim rFound          As Range
   
    Const strPath   As String = "C:\Searchfolderhere\"        'change folder path to suit your needs
   
    Do
        strSearch = InputBox("Please enter the Search Term.", "Search")
        'cancel pressed
        If StrPtr(strSearch) = 0 Then Exit Sub
    Loop Until Len(strSearch) > 0
   
    Application.ScreenUpdating = False
   
    Set wkbDest = ThisWorkbook
   
    Set wOut = wkbDest.Worksheets.Add
   
    wOut.Range("A1:D1") = Array("Workbook", "Worksheet", "Cell", "Text in Cell")
   
    strFileName = Dir(strPath & "\" & "*.xlsx", vbDirectory)
   
    'Loop through all Files in path
    Do While Len(strFileName) > 0
   
        Set wkbSource = Workbooks.Open(strPath & strFileName, 0, True)
       
        For Each wks In wkbSource.Worksheets
            Set rFound = wks.Range("A:A").Find(strSearch, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
            If Not rFound Is Nothing Then
                strFirstAddress = rFound.Address
                Do
                   
                    wOut.Cells(wOut.Cells(wOut.Rows.Count, "A").End(xlUp).Row + 1, 1).Resize(1, 4).Value = _
                    Array(wkbSource.Name, wks.Name, rFound.Address, rFound.Value)
                   
                    Set rFound = wks.Range("A:A").FindNext(rFound)
                Loop While rFound.Address <> strFirstAddress
            End If
            Set rFound = Nothing
        Next wks
       
        wkbSource.Close False
        Set wkbSource = Nothing
        strFileName = Dir
    Loop
   
    Application.ScreenUpdating = True
End Sub

Dave

Thank you for the help. You actually help me realize a mistake I kept making. I forgot to include a trailing backslash in my directory location. After fixing that the problem seem to be running fine, but all that was printed in my current workbook was

Workbook

Worksheet

Cell

Text in Cell