VBA Copy and Paste all columns that contain partial match

Ok_category1816

New Member
Joined
Feb 5, 2025
Messages
2
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
I have a work project that I’m trying to do some VBA work with. I have 1 workbook that’s called “Log” and another few workbooks (could be 1 or more) that follow the format “######text” where there are always 6 digits followed by text or varying lengths that we’ll refer to as “export sheets.” The export books have a bunch of columns that represent samples run overnight and all of the quality controls (“QCs”) need to be charted. I need to copy and paste all columns that contain “ICV*” and “LCS*” in Row 1 to the Log but I’m struggling to loop through and copy all instances. Any advice? I’m super new to all things coding so thanks in advance!
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Hello,

Looping is easy to understand and very common in programming, but when working with Excel you can take advantage of the Range.AutoFilter method (Excel) | Microsoft Learn.

Combined with Range.SpecialCells method (Excel) | Microsoft Learn (xlCellTypeVisible) it is a very powerful tool that allows you to filter columns easily.

If you want more help, it would be helpful to post some samples of the data and expected result, as obviously we need to know the structure of the data.

If you want to do it by yourself, i recommend using the macro recorder and putting a filter manually on the column, to begin with and understand how it works.
 
Upvote 0
Hello,

Since it is a common question, i went a bit ahead and wrote a function that hopefully should take the annoying work away from you.

You can use as I did in the TestFilter sub below.
You can either put 1 criterion of any kind, or an array of criteria, all of the same kind.

Limits:
  • If you want to do partial matching as you describe, you cannot do it with the array criteria, it has to be alone. So you need to call the function for each criteria. But since it is almost instant, it should not be a big deal
  • Your column needs no blank cells, it will stop filtering on the first blank row
  • It will remove filters from the looked sheet, to ensure no value is missed
VBA Code:
Public Function GetFilteredValues(colHeader As Range, criteria As Variant, Optional ByVal colOffset As Long = 0) As Variant
  ' removing potential filters
  With colHeader.Worksheet
    If .FilterMode Then .ShowAllData
  End With
  
  ' Check if the value is present in given column
  If IsArray(criteria) Then
    Dim i As Long, isPresent As Boolean
    For i = LBound(criteria) To UBound(criteria)
      isPresent = isPresent Or _
        Not (Range(colHeader.Offset(1, 0), colHeader.End(xlDown)).Find(criteria(i), LookIn:=xlValues, LookAt:=xlPart) Is Nothing)
    Next i
    If Not isPresent Then
      GetFilteredValues = Array("")
      Exit Function
    End If
  Else
    If Range(colHeader.Offset(1, 0), colHeader.End(xlDown)).Find(criteria, LookIn:=xlValues, LookAt:=xlPart) Is Nothing Then
      GetFilteredValues = Array("")
      Exit Function
    End If
  End If

  ' filtering the column
  If IsArray(criteria) Then
    colHeader.AutoFilter Field:=1, Criteria1:=criteria, Operator:=xlFilterValues
  Else
    colHeader.AutoFilter Field:=1, Criteria1:=criteria
  End If
  ' saving the filtered values
  ' (we know there is at least one so we do not check the last row)
  Dim filRng As Range
  Set filRng = Range( _
    colHeader.Offset(1, 0), _
    colHeader.End(xlDown) _
  ).SpecialCells(xlCellTypeVisible).Offset(0, colOffset)
  
  ' to an array
  Dim data() As Variant, cellI As Range
  ReDim data(1 To filRng.Cells.Count, 1 To 1)
  i = 1
  For Each cellI In filRng
    data(i, 1) = cellI.Value2
    i = i + 1
  Next cellI
  
  ' disactivating autofilter
  colHeader.AutoFilter
  
  ' returning filtered values
  GetFilteredValues = data
End Function

Sub TestFilter()
  Dim fil1 As Variant
  
  ' find all cells in column A (header = A1) of sheet2 equal to the value 3
  fil1 = GetFilteredValues(Sheet2.Range("A1"), 3)
  If UBound(fil1, 1) > 0 Then ' check to ensure the value was found
    Sheet1.Range("A2").Resize(UBound(fil1, 1), 1).Value2 = fil1
  End If
  
  ' find all cells in column A (header = A1) of sheet2 equal to the string 3 or A
  fil1 = GetFilteredValues(Sheet2.Range("A1"), Array("3", "A"))
  If UBound(fil1, 1) > 0 Then
    Sheet1.Range("B2").Resize(UBound(fil1, 1), 1).Value2 = fil1
  End If
  fil1 = GetFilteredValues(Sheet2.Range("A1"), Array("G", "H"))
  If UBound(fil1, 1) > 0 Then
    Sheet1.Range("C2").Resize(UBound(fil1, 1), 1).Value2 = fil1
  End If
  
  ' find all cells in column C (=B1+offset=1) (header = B1) of sheet3 equal to the strings listed
  fil1 = GetFilteredValues(Sheet3.Range("B1"), Array("I", "G", "H", "5"), 1)
  If UBound(fil1, 1) > 0 Then
    Sheet1.Range("D2").Resize(UBound(fil1, 1), 1).Value2 = fil1
  End If
  
  ' find all cells in column B (header = B1) of sheet3 equal containing the string "I"
  fil1 = GetFilteredValues(Sheet3.Range("B1"), "*I*")
  If UBound(fil1, 1) > 0 Then
    Sheet1.Range("E2").Resize(UBound(fil1, 1), 1).Value2 = fil1
  End If
End Sub
 
Upvote 0
Here's the example! I need the yellow stuff to be copied into the Log but there might be only 1 column or there could be multiple.
 

Attachments

  • Excel Example.PNG
    Excel Example.PNG
    191.8 KB · Views: 2
Upvote 0
Oh… You want to filter by columns, not rows… + you have merged cells.

The problem is totally different from what i imagined, the above is no longer valid.

Would the Sub below work for you?
Note : I do not know how you retrieve the dates in the first row, and i understood nothing about your workbooks names so i took the ones of the screenshot.
VBA Code:
Sub Example()
  Dim fromSht As Worksheet, outSht As Worksheet
  Set fromSht = Workbooks("020325myco2.xlsx").Worksheets(1)
  Set outSht = Workbooks("RPD Log LCMS1 2025.xlsx").Worksheets("ICVm")
 
  Dim scannedVals As Variant
  With fromSht.Range("A1")
    scannedVals = Range(.Cells, .End(xlToRight)).Value2
  End With

  Dim colsIdx() As Long
  ' get names
  ReDim colsIdx(1 To 1): colsIdx(1) = 1

  ' retrieving the columns numbers
  Dim i As Long
  For i = LBound(scannedVals, 2) To UBound(scannedVals, 2)
    If (scannedVals(1, i) Like "ICV*") Or (scannedVals(1, i) Like "LCS*") Then
      ReDim colsIdx(LBound(colsIdx) To UBound(colsIdx) + 1)
      colsIdx(UBound(colsIdx)) = scannedVals(1, i)
    End If
  Next i
 
  ' copy the columns
  For i = LBound(colsIdx) To UBound(colsIdx)
    With fromSht.Cells(2, colsIdx(i))
      Range(.Cells, .End(xlDown)).Copy outSht.Cells(2, i)
    End With
  Next i

End Sub
 
Upvote 0

Forum statistics

Threads
1,226,453
Messages
6,191,135
Members
453,642
Latest member
jefals

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