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

frostedzeo

New Member
Joined
Aug 9, 2022
Messages
2
Office Version
  1. 2010
Platform
  1. Windows
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.

VBA Code:
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
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
Hi welcome to forum

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

VBA Code:
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
 
Upvote 0
Hi welcome to forum

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

VBA Code:
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

WorkbookWorksheetCellText in Cell
 
Upvote 0

Forum statistics

Threads
1,223,098
Messages
6,170,099
Members
452,301
Latest member
QualityAssurance

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top