CODEWITHSUNDEEP
excelvba
Mirko Stanisic
Mirko Stanisic

Reputation: 57

Combine data from multiple worksheets to one sheet on key word from column

im sorry for making similar question but im run into a problem, bcs i don t know very good VBA coding... I found many similar questions, and i found a code that i can apply to my needs. I found code here But i don't know how to edit that code so that he can work in my Workbook. I have workbook with 35 worksheets, all with same format, values are in columns "A:F", in column "E" i have text "On Stock" and "Sent", i want all rows from all worksheets that have "On Stock" value in column "E" to be copied into one worksheet named "Blanko List". I tried to edit code myself, but it can t run, nothing happens. Thanks in advance. Edited code

Sub CommandButton4_Click()
    Dim wM As Worksheet, ws As Worksheet
    Dim r As Long, lr As Long, nr As Long, y As Long
    Dim c As Range, firstaddress As String
    Application.ScreenUpdating = False
    Set wM = Sheets("Blanko List")
    lr = wM.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
    If lr > 1 Then wM.Range("A2:G" & lr).ClearContents
    For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "Blanko List" Then
    y = 0
    On Error Resume Next
    y = Application.CountIf(ws.Columns(7), "On Stock")
    On Error GoTo 0
    If y > 1 Then
      firstaddress = ""
      With ws.Columns(7)
        Set c = .Find("On Stock", LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
          firstaddress = c.Address
          Do
            nr = wM.Range("G" & Rows.Count).End(xlUp).Offset(1).Row
            ws.Range("A" & c.Row & ":G" & c.Row).Copy wM.Range("A" & nr)
            Application.CutCopyMode = False
            Set c = .FindNext(c)
          Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
      End With
    End If
  End If
Next ws
wM.Activate
Application.ScreenUpdating = True
    ''''

Original code:

    Option Explicit
    Sub GetYes()

    Dim wM As Worksheet, ws As Worksheet
    Dim r As Long, lr As Long, nr As Long, y As Long
    Dim c As Range, firstaddress As String
    Application.ScreenUpdating = False
    Set wM = Sheets("Master")
    lr = wM.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
    If lr > 1 Then wM.Range("A2:G" & lr).ClearContents
    For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "Master" Then
    y = 0
    On Error Resume Next
    y = Application.CountIf(ws.Columns(7), "Yes")
    On Error GoTo 0
    If y > 1 Then
      firstaddress = ""
      With ws.Columns(7)
        Set c = .Find("Yes", LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
          firstaddress = c.Address
          Do
            nr = wM.Range("G" & Rows.Count).End(xlUp).Offset(1).Row
            ws.Range("A" & c.Row & ":G" & c.Row).Copy wM.Range("A" & nr)
            Application.CutCopyMode = False
            Set c = .FindNext(c)
          Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
      End With
    End If
  End If
Next ws
wM.Activate
Application.ScreenUpdating = True
End Sub

Upvotes: 1

Views: 128

Answers (2)

VBasic2008
VBasic2008

Reputation: 54807

Copy Criteria Rows

Option Explicit

Sub CopyCriteriaRows()
    
    ' Source
    Const sCols As String = "A:F"
    Const sfRow As Long = 2
    Const scCol As Long = 5
    Const sCriteria As String = "On Stock"
    ' Destination
    Const dName As String = "Blanco List"
    Const dFirst As String = "A2"
    ' Exceptions
    Const ExceptionsList As String = "Blanco List" ' add more
    Const ListSeparator As String = ","
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the names of the worksheets to be 'processed' to an array.
    Dim wsNames As Variant
    wsNames = ArrWorksheetNames(wb, ExceptionsList, ListSeparator)
    If IsEmpty(wsNames) Then Exit Sub ' no worksheet found
    
    ' Create a reference to the first destination row range.
    ' Note that the number of columns is equal in source and destination.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim cCount As Long: cCount = dws.Columns(sCols).Columns.Count
    Dim drrg As Range: Set drrg = dws.Range(dFirst).Resize(, cCount)
    
    Dim sws As Worksheet ' Source Worksheet
    Dim srg As Range ' Source Range
    Dim sfrrg As Range ' Source First Row Range
    Dim drg As Range ' Destination Range
    
    Dim Data As Variant ' Data Array
    Dim cValue As Variant ' Current Value
    
    Dim dr As Long ' Destination Row Counter
    Dim sr As Long ' Source Row Counter
    Dim c As Long ' Column Counter
    
    For Each sws In wb.Worksheets(wsNames)
        ' Create a reference to the current Source First Row Range.
        Set sfrrg = sws.Columns(sCols).Rows(sfRow)
        Set srg = Nothing
        ' Create a reference to the current Source Range.
        Set srg = RefColumns(sfrrg)
        If Not srg Is Nothing Then ' the current Source Range is not empty
            ' Write the values from the current Source Range to the Data Array.
            Data = GetRange(srg)
            ' Write the matches to the top of the Data Array. The size
            ' of the array stays the same but 'dr' is used: to track
            ' the number of, to move, and finally, to write (to the worksheet)
            ' the 'destination' values.
            dr = 0
            For sr = 1 To UBound(Data, 1)
                cValue = Data(sr, scCol)
                If StrComp(CStr(cValue), sCriteria, vbTextCompare) = 0 Then
                    dr = dr + 1
                    For c = 1 To cCount
                        Data(dr, c) = Data(sr, c)
                    Next c
                End If
            Next sr
            If dr > 0 Then ' there have been matches
                ' Create a reference to the Destination Range.
                Set drg = drrg.Resize(dr)
                ' Write only the 'destination' values (dr) from
                ' the Data Array to the Destination Range.
                drg.Value = Data
                ' Create a reference to the next Destination First Row Range.
                Set drrg = drrg.Offset(dr)
            End If
        End If
    Next sws
    
    ' The 'Clear Range' is the range spanning
    ' from the last 'Destination First Row Range'
    ' (which was referenced, but was not written to)
    ' to the bottom-most row range of the worksheet.
    Dim crg As Range
    Set crg = drrg.Resize(dws.Rows.Count - drrg.Row + 1)
    crg.ClearContents
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the names of the worksheets of a workbook ('wb'),
'               that are not included in a list ('ExceptionsList'),
'               in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrWorksheetNames( _
    ByVal wb As Workbook, _
    Optional ByVal ExceptionsList As String = "", _
    Optional ByVal ListSeparator As String = ",", _
    Optional ByVal FirstIndex As Long = 0) _
As Variant
    If wb Is Nothing Then Exit Function
    
    Dim wsCount As Long: wsCount = wb.Worksheets.Count
    If wsCount = 0 Then Exit Function ' There could e.g. only be charts.
    
    Dim IndexDiff As Long: IndexDiff = FirstIndex - 1
    Dim LastIndex As Long: LastIndex = wsCount + IndexDiff
    Dim Arr() As String: ReDim Arr(FirstIndex To LastIndex)
    Dim n As Long: n = IndexDiff
    
    Dim ws As Worksheet
    
    If Len(ExceptionsList) = 0 Then
        For Each ws In wb.Worksheets
            n = n + 1
            Arr(n) = ws.Name
        Next ws
    Else
        Dim Exceptions() As String
        Exceptions = Split(ExceptionsList, ListSeparator)
        For Each ws In wb.Worksheets
            If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
                n = n + 1
                Arr(n) = ws.Name
            End If
        Next ws
    End If
    
    Select Case n
    Case IndexDiff
        Exit Function
    Case Is < LastIndex
        ReDim Preserve Arr(FirstIndex To n)
    End Select
    
    ArrWorksheetNames = Arr
    
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the range spanning from the first row
'               of a given range ('rg') to the row containing the bottom-most
'               non-empty cell of the given range's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
    ByVal rg As Range) _
As Range
    If rg Is Nothing Then Exit Function
    
    With rg.Rows(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If lCell Is Nothing Then Exit Function ' empty range
        Set RefColumns = .Resize(lCell.Row - .Row + 1)
    End With

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal rg As Range) _
As Variant
    If rg Is Nothing Then Exit Function
    
    Dim rData As Variant
    If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell only
        ReDim rData(1 To 1, 1 To 1): rData(1, 1) = rg.Value
    Else
        rData = rg.Value
    End If

    GetRange = rData
End Function


' Irrelevant to the Question,
' but for a better understanding of `ArrWorksheetNames`.

Sub ArrWorksheetNamesTEST()
    
    Const ExceptionsList As String = "Sheet1,Sheet2,Sheet3,Sheet4"
    Const ListSeparator As String = ","
    Const FirstIndex As Long = 4
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim wsNames As Variant
    wsNames = ArrWorksheetNames(wb, ExceptionsList, ListSeparator, FirstIndex)
    
    If IsEmpty(wsNames) Then
        Debug.Print "No worksheets."
    Else
        Debug.Print "[" & LBound(wsNames) & "," & UBound(wsNames) & "]" _
            & vbLf & Join(wsNames, vbLf)
    End If

End Sub

Upvotes: 1

pgSystemTester
pgSystemTester

Reputation: 9917

You can use this to develop an array of values and then dump them into some collection sheet.

Sub grabAllSheets()
Const exclude_Sheet = "Result" ' name of sheet to drop data
Const tangoText = "On Stock"
Dim ws As Worksheet, aCell As Range

ReDim allvalues(1 To 6, 1 To 1)

Dim i As Long, c As Long


For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> exclude_Sheet Then
        For Each aCell In Intersect(ws.Range("E:E"), ws.UsedRange).Cells
            If aCell.Value = tangoText Then
                i = i + 1
                ReDim Preserve allvalues(1 To 6, 1 To i)
                
                For c = 1 To Range("F:F").Column
                    allvalues(c, i) = ws.Cells(aCell.Row, c).Value
                Next c
            End If
        Next aCell
    End If
Next ws

Dim theRow As Long
With Sheets(exclude_Sheet)
    theRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Cells(IIf(theRow = 1, 1, theRow + 1), 1).Resize(i, 6).Value = _
        Application.WorksheetFunction.Transpose(allvalues)
End With



End Sub

Upvotes: 1

Related Questions