VBA Loop to Copy Cell Value from worksheets to new worksheet with Worksheet Name

hondahawkrider

New Member
Joined
Nov 12, 2015
Messages
12
I have some VBA code that works great.. It loops thru my worksheets looking for the value "Red Hat" and copies that data to worksheet called "Summary" ... However, I would also like it to put the name of the worksheet name where the data ("Red Hat") was found as well . I am having a hard time adding it to the loop .. .it's been a while since Ive need to to do any vba programminmg ... any help is appreciated ...

VBA Code:
Sub RedHatCopyRowsBasedOnPartialMatch()

    Dim ws As Worksheet, summarySheet As Worksheet
    Dim lastRow As Long, i As Long, cellValue As String
    
    ' Set the summary sheet where you want to paste data
    Set summarySheet = ThisWorkbook.Worksheets("Summary")
    summarySheet.Range("A1").ClearContents ' Clear existing data on summary sheet

    ' Loop through all worksheets in the workbook
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Summary" Then ' Skip the summary sheet itself
            lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row ' Find last row with data
            
            For i = 1 To lastRow
                cellValue = ws.Cells(i, "A").Value ' Get value from column A
                
                ' Check if the cell value contains your target partial string (modify "PART" as needed)
 '              If InStr(1, cellValue, "PART") > 0 Then
                If InStr(1, cellValue, "Red Hat") > 0 Then
                    ws.Rows(i).Copy summarySheet.Cells(summarySheet.Rows.Count, "A").End(xlUp).Offset(1, 0) ' Paste to summary sheet
                End If
            Next i
        End If
    Next ws

End Sub
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
Hello,
To gain on performances, for the loop what about something like this?
And then, where do you want the sheet name to be put exactly? On each row, on a row above?
VBA Code:
Sub RedHatCopyRowsBasedOnPartialMatch()

  Dim ws As Worksheet, summarySheet As Worksheet
  Dim lastRow As Long, i As Long, cellValue As String

  ' Set the summary sheet where you want to paste data
  Set summarySheet = ThisWorkbook.Worksheets("Summary")
  With summarySheet.Range("A1")
    ' Clear existing data on summary sheet
    Range(.Cells, .End(xlDown)).ClearContents
  End With

  ' Loop through all worksheets in the workbook
  For Each ws In ThisWorkbook.Worksheets
    ' Skip the summary sheet itself
    If ws.Name <> "Summary" Then
      If Not (ws.Range("A:A").Find("Red Hat", LookIn:=xlValues) Is Nothing) Then
        ws.Range("A1").AutoFilter Field:=1, Criteria1:="=*Red Hat*"
        ' skipping the first row otherwise the "filtering row" is copied aswell
        With ws.Range("A1")
          .Range(.Offset(1, 0), .End(xlDown)).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            summarySheet.Cells(summarySheet.Rows.Count, "A").End(xlUp).Offset(1, 0)
        End With

        ws.Range("A1").AutoFilter
      End If
    End If
  Next ws
    
End Sub
 
Upvote 0
After works ... My script pulls the entire row (which is a and b columns .. My script pulls in the row with Red Hat,, which is both columns A/B ... I was tring to finda way to put the tab name is Col C...
 

Attachments

  • MRexcel02052025.jpg
    MRexcel02052025.jpg
    169 KB · Views: 4
Upvote 0
Hi
your approach not the fastest method but if works ok for you & just want to copy matching cells in Columns A & B with sheet name in Column C then try replacing the copy part of your code with following & see if does what you want

VBA Code:
           If InStr(1, cellValue, "Red Hat") > 0 Then
                With summarySheet.Cells(summarySheet.Rows.Count, "A").End(xlUp).Offset(1, 0)
                    .Resize(, 2).Value = ws.Cells(i, 1).Resize(, 2).Value
                    .Offset(, 2).Value = ws.Name
                End With
            End If

Dave
 
Upvote 0
After works ... My script pulls the entire row (which is a and b columns .. My script pulls in the row with Red Hat,, which is both columns A/B ... I was tring to finda way to put the tab name is Col C...
Ohhh okay no problem, it is because it stops at the first empty row, and since your code started in A1 i thought your data were starting there too. However the "header row" let's say, is A4.

Therefore adapting the code gives:

VBA Code:
Sub RedHatFindMultiple()
  Dim ws As Worksheet, summarySheet As Worksheet
  ' Set the summary sheet where you want to paste data
  Set summarySheet = ThisWorkbook.Worksheets("Summary")
  With summarySheet.Range("A1")
    ' Clear existing data on summary sheet
    Range(.Cells, .End(xlDown)).ClearContents
  End With
  ' Loop through all worksheets in the workbook
  For Each ws In ThisWorkbook.Worksheets
    ' Skip the summary sheet itself
    If ws.Name <> "Summary" Then
      If Not (ws.Range("A:A").Find("Red Hat", LookIn:=xlValues) Is Nothing) Then
        ws.Range("A4").AutoFilter Field:=1, Criteria1:="=*Red Hat*"
        ' adding the sheet's name on the right
        summarySheet.Cells(summarySheet.Rows.Count, "A").End(xlUp).End(xlToRight).Offset(1, 1).Value2 = _
          ws.Name
        ' copy of the filtered values
        With ws.Range("A4")
          .Range(.Offset(1, 1), .End(xlDown)).SpecialCells(xlCellTypeVisible).Copy _
            summarySheet.Cells(summarySheet.Rows.Count, "A").End(xlUp).Offset(1, 0)
        End With
        ws.Range("A4").AutoFilter
      End If
    End If
  Next ws
End Sub

However, if there is ONLY ONE Red Hat build on each machine, you might use the code below which is easier and faster :
VBA Code:
Sub RedHatFindSimple()
  Dim ws As Worksheet, summarySheet As Worksheet
  ' Set the summary sheet where you want to paste data
  Set summarySheet = ThisWorkbook.Worksheets("Summary")
  With summarySheet.Range("A1")
    ' Clear existing data on summary sheet
    Range(.Cells, .End(xlDown)).ClearContents
  End With
  Dim redHatRng As Range
  ' Loop through all worksheets in the workbook
  For Each ws In ThisWorkbook.Worksheets
    ' Skip the summary sheet itself
    If ws.Name <> "Summary" Then
      Set redHatRng = ws.Range("A:A").Find("Red Hat", LookIn:=xlValues)
      If Not (redHatRng Is Nothing) Then
        ' adding the Red hat build, its version, and the sheet name
        summarySheet.Cells(summarySheet.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, 3).Value2 = _
          Array(redHatRng.Value2, redHatRng.Offset(0, 1).Value2, ws.Name)
      End If
    End If
  Next ws
    
End Sub
 
Upvote 0

Forum statistics

Threads
1,226,453
Messages
6,191,136
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