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