Finding and copying all cell values that start with "U" using VBA

[jardenp]

This may be a long shot, but if there is an excel board community that can help with this, I'm confident this is the one.

I want to write a script that runs through all Excel workbooks in a folder (let's say S:\Folder) and copies all cell values where the first two character are "U1". So, for instance, this would pull "U10245" from B5 in Workbook1, "U15555884455754454" from D47 in Workbook2, etc. and paste them into a list on a new sheet. I don't know if this would make a difference, but formulas are not in play. That is, I'm not concerned about copying cells where a formula produces a value that starts with "U1." If it pulls those in too (I don't think there are any) that's fine, but it's not necessary.

Thanks!

JP in IN

 

[LloydFinancials]

Try this out. Modified from Ron DeBruin: Find value in Range, Sheet or Sheets with VBA

Public Sub test() '*****Place macro in workbook where you have the list
   Dim wbk As Workbook
   Dim Filename As String
   Dim Path As String
   Dim NewSh As Worksheet
   Dim Rcount As Long
   Dim ws As Worksheet
   Dim FirstAddress As String
   Dim MyArr As Variant
   Dim Rng As Range
   Dim i As Long
      
   With Application
      .ScreenUpdating = False
      .EnableEvents = False
   End With
   
   Set NewSh = Sheets("Sheet1") '*****Sheet with list
   Path = "C:\Users\Public\Save.72815\Excel\TempLoopFolder\" '*****Path
   Filename = Dir(Path & "*.xlsm") '*****Extension or "*.xls" or "*.xls*"
   Rcount = 0
   Do While Len(Filename) > 0
      Set wbk = Workbooks.Open(Path & Filename)
      For Each ws In Worksheets
         MyArr = Array("*U1*") '*****Lookup value
         With ws.UsedRange '
            For i = LBound(MyArr) To UBound(MyArr)
               Set Rng = .Find(What:=MyArr(i), _
               After:=.Cells(.Cells.Count), _
               LookIn:=xlFormulas, _
               LookAt:=xlPart, _
               SearchOrder:=xlByRows, _
               SearchDirection:=xlNext, _
               MatchCase:=False)
               If Not Rng Is Nothing Then
                  FirstAddress = Rng.Address
                  Do
                     Rcount = Rcount + 1
                     Rng.Copy NewSh.Range("A" & Rcount) '*****column with list
                     Set Rng = .FindNext(Rng)
                  Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
               End If
            Next i
         End With
      Next ws
      wbk.Close True
      Filename = Dir
   Loop
   
   With Application
      .ScreenUpdating = True
      .EnableEvents = True
   End With
End Sub

Luke

 

[jardenp]

Wow. Thanks! So I should replace "C:\Users\Public\Save.72815\Excel\TempLoopFolder\" with the location of the folder containing the workbooks?

Also, I'm not sure what you mean by "Place macro in workbook where you have the list" I want it to automatically run on all workbooks in a folder--there is no one workbook with a list.

Thanks again!

 

[jardenp]

Actually, I know what you meant about the list. Run it in the workbook where I want the final list.

I just tested this and it appears to have worked. Thank you, thank you, thank you!

 

[LloydFinancials]

Great! you're welcome.