Copy data from multiple sheets into 1 based on criteria

[atame]

Hi all,

I have a document that has multiple sheets, I need to search column A using an inputstring to find all values that match them copy them to the MergedData sheet. It needs to excluding "SUB PAYMENT FORM", "Details" and "MergeData" from the search. It needs to search each sheet starting at row 16 working down til last row.

In the merged data sheet i need the data to start being copied at Cell A1, followed by A2 and so on...

I would like for when the button has been click and data copied i would like to have a message box display, stating the sheet names where data has been copied from, i would also like it to display the sheets name of where no data was found.

Below is the code that i have at the moment, it searches all the relevant sheets and copys the data to the MergedData sheet. But it does not give me the message boxes stating where data was found or not.

It also pasted the data in the MergedData sheet starting in row 2 rather that row 1.

Any help you can provide would be greatly appreciated.

Thanks
Aarron

Sub SearchForString()
Dim FirstAddress As String, 
WhatFor As String
Dim Cell As Range, 
Sheet As Worksheet    
With Application        
.ScreenUpdating = False        
.EnableEvents = False        
.CutCopyMode = False    
End With    

WhatFor = InputBox("What are you looking for?", "Search Criteria")
Worksheets("MergedData").Cells.Clear

If WhatFor = Empty Then Exit Sub
For Each Sheet In SheetsIf Sheet.Name <> "SUB PAYMENT" And Sheet.Name <> "MergedData" And Sheet.Name <> "Details" Then

With Sheet.Columns(1)
Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlWhole)

If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Cell.EntireRow.Copy Destination:=Sheets("MergedData").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)Set Cell = .FindNext(Cell)Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
End If
End With
End If
Next Sheet
Set Cell = Nothing
End Sub

 

[pbornemeier]

Option Explicit

Sub SearchForString()
    Dim FirstAddress As String, WhatFor As String
    Dim Cell As Range, Sheet As Worksheet
    Dim sSheetsWithData As String, sSheetsWithoutData As String
    Dim lSheetRowsCopied As Long, lAllRowsCopied As Long
    Dim bFound As Boolean
    Dim sOutput As String
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .CutCopyMode = False
    End With
    
    WhatFor = InputBox("What are you looking for?", "Search Criteria")
    
    Worksheets("MergedData").Cells.Clear
    
    If WhatFor = Empty Then Exit Sub
    
    For Each Sheet In Sheets
        If Sheet.Name <> "SUB PAYMENT" And Sheet.Name <> "MergedData" And Sheet.Name <> "Details" Then
            bFound = False
            With Sheet.Columns(1)
                Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlWhole)
                If Not Cell Is Nothing Then
                    bFound = True
                    lSheetRowsCopied = 0
                    FirstAddress = Cell.Address
                    Do
                        lSheetRowsCopied = lSheetRowsCopied + 1
                        Cell.EntireRow.Copy Destination:=Sheets("MergedData").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                        Set Cell = .FindNext(Cell)
                    Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
                Else
                    bFound = False
                End If
                If bFound Then
                    sSheetsWithData = sSheetsWithData & "    " & Sheet.Name & " (" & lSheetRowsCopied & ")" & vbLf
                    lAllRowsCopied = lAllRowsCopied + lSheetRowsCopied
                Else
                    sSheetsWithoutData = sSheetsWithoutData & "    " & Sheet.Name & vbLf
                End If
            End With
        End If
    Next Sheet
    
    If sSheetsWithData <> vbNullString Then
        sOutput = "Sheets with data (rows copied)" & vbLf & vbLf & sSheetsWithData & vbLf & _
            "Total rows copied = " & lAllRowsCopied & vbLf & vbLf
    Else
        sOutput = "No sheeTs contained data to be copied" & vbLf & vbLf
    End If
    
    If sSheetsWithoutData <> vbNullString Then
        sOutput = sOutput & "Sheets with no rows copied:" & vbLf & vbLf & sSheetsWithoutData
    Else
        sOutput = sOutput & "All sheets had data that was copied."
    End If
    
    If sOutput <> vbNullString Then MsgBox sOutput, , "Copy Report"
    
    With Worksheets("MergedData")
        If .Cells(1, 1).Value = vbNullString Then .Rows(1).Delete
    End With
    
    Set Cell = Nothing
    
End Sub

 

[atame]

Option Explicit

Sub SearchForString()
    Dim FirstAddress As String, WhatFor As String
    Dim Cell As Range, Sheet As Worksheet
    Dim sSheetsWithData As String, sSheetsWithoutData As String
    Dim lSheetRowsCopied As Long, lAllRowsCopied As Long
    Dim bFound As Boolean
    Dim sOutput As String
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .CutCopyMode = False
    End With
    
    WhatFor = InputBox("What are you looking for?", "Search Criteria")
    
    Worksheets("MergedData").Cells.Clear
    
    If WhatFor = Empty Then Exit Sub
    
    For Each Sheet In Sheets
        If Sheet.Name <> "SUB PAYMENT" And Sheet.Name <> "MergedData" And Sheet.Name <> "Details" Then
            bFound = False
            With Sheet.Columns(1)
                Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlWhole)
                If Not Cell Is Nothing Then
                    bFound = True
                    lSheetRowsCopied = 0
                    FirstAddress = Cell.Address
                    Do
                        lSheetRowsCopied = lSheetRowsCopied + 1
                        Cell.EntireRow.Copy Destination:=Sheets("MergedData").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                        Set Cell = .FindNext(Cell)
                    Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
                Else
                    bFound = False
                End If
                If bFound Then
                    sSheetsWithData = sSheetsWithData & "    " & Sheet.Name & " (" & lSheetRowsCopied & ")" & vbLf
                    lAllRowsCopied = lAllRowsCopied + lSheetRowsCopied
                Else
                    sSheetsWithoutData = sSheetsWithoutData & "    " & Sheet.Name & vbLf
                End If
            End With
        End If
    Next Sheet
    
    If sSheetsWithData <> vbNullString Then
        sOutput = "Sheets with data (rows copied)" & vbLf & vbLf & sSheetsWithData & vbLf & _
            "Total rows copied = " & lAllRowsCopied & vbLf & vbLf
    Else
        sOutput = "No sheeTs contained data to be copied" & vbLf & vbLf
    End If
    
    If sSheetsWithoutData <> vbNullString Then
        sOutput = sOutput & "Sheets with no rows copied:" & vbLf & vbLf & sSheetsWithoutData
    Else
        sOutput = sOutput & "All sheets had data that was copied."
    End If
    
    If sOutput <> vbNullString Then MsgBox sOutput, , "Copy Report"
    
    With Worksheets("MergedData")
        If .Cells(1, 1).Value = vbNullString Then .Rows(1).Delete
    End With
    
    Set Cell = Nothing
    
End Sub

Hi Phil,

Thank you very much for the code, it works perfectly. You are a legend!!!!!

If i could be so cheeky and ask you to have a look at some of my other questions, i would greatly appreciate it!

Thanks
Aarron

 

[atame]

Option Explicit

Sub SearchForString()
    Dim FirstAddress As String, WhatFor As String
    Dim Cell As Range, Sheet As Worksheet
    Dim sSheetsWithData As String, sSheetsWithoutData As String
    Dim lSheetRowsCopied As Long, lAllRowsCopied As Long
    Dim bFound As Boolean
    Dim sOutput As String
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .CutCopyMode = False
    End With
    
    WhatFor = InputBox("What are you looking for?", "Search Criteria")
    
    Worksheets("MergedData").Cells.Clear
    
    If WhatFor = Empty Then Exit Sub
    
    For Each Sheet In Sheets
        If Sheet.Name <> "SUB PAYMENT" And Sheet.Name <> "MergedData" And Sheet.Name <> "Details" Then
            bFound = False
            With Sheet.Columns(1)
                Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlWhole)
                If Not Cell Is Nothing Then
                    bFound = True
                    lSheetRowsCopied = 0
                    FirstAddress = Cell.Address
                    Do
                        lSheetRowsCopied = lSheetRowsCopied + 1
                        Cell.EntireRow.Copy Destination:=Sheets("MergedData").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                        Set Cell = .FindNext(Cell)
                    Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
                Else
                    bFound = False
                End If
                If bFound Then
                    sSheetsWithData = sSheetsWithData & "    " & Sheet.Name & " (" & lSheetRowsCopied & ")" & vbLf
                    lAllRowsCopied = lAllRowsCopied + lSheetRowsCopied
                Else
                    sSheetsWithoutData = sSheetsWithoutData & "    " & Sheet.Name & vbLf
                End If
            End With
        End If
    Next Sheet
    
    If sSheetsWithData <> vbNullString Then
        sOutput = "Sheets with data (rows copied)" & vbLf & vbLf & sSheetsWithData & vbLf & _
            "Total rows copied = " & lAllRowsCopied & vbLf & vbLf
    Else
        sOutput = "No sheeTs contained data to be copied" & vbLf & vbLf
    End If
    
    If sSheetsWithoutData <> vbNullString Then
        sOutput = sOutput & "Sheets with no rows copied:" & vbLf & vbLf & sSheetsWithoutData
    Else
        sOutput = sOutput & "All sheets had data that was copied."
    End If
    
    If sOutput <> vbNullString Then MsgBox sOutput, , "Copy Report"
    
    With Worksheets("MergedData")
        If .Cells(1, 1).Value = vbNullString Then .Rows(1).Delete
    End With
    
    Set Cell = Nothing
    
End Sub

Hi Phil,

Could you have a look into SUMIF for me please, basically i need the same button event to perform a sum if on the data the gets copied over. so once all the data has been copied from all sheets it will then search Column B for all duplicates it will then add up the totals in colums I,J and L then delete the duplicated rows.

I would like to have the one button perform both tasks, but if it is not possible then a second button would suffice. I have some code that works when doing the SUMIF but cant seem to integrate it with the other code. (not sure if it is helpful but i will supply it anyway.

Private Sub CommandButton1_Click()Application.ScreenUpdating = False      '### Excel wont update its screen while executing this macro. This is a huge performace boost
Dim SUMcols()                         '### declare a second empty array for our sum columns


SUMcols() = Array(9, 10, 12)         '### the second array stores the columns which should be summed up
 


'### the next line sets our range for searching dublicates. Starting at cell A2 and ending at the last used cell in column A
Set searchrange = Range([b2], Columns(2).Find(what:="*", after:=[b1], searchdirection:=xlPrevious))


For Each cell In searchrange            '### now we start looping through each cell of our searchrange
    Set Search = searchrange.Find(cell, after:=cell, lookat:=xlWhole)   '### searches for a dublicate. If no dub exists, it finds only itself
    Do While Search.Address <> cell.Address     '### until we find our starting cell again, these rows are all dublicates


        For i = 0 To UBound(SUMcols)    '### loop through all columns for calculating the sum
            '### next line sums up the cell in our starting row and its counterpart in its dublicate row
            Cells(cell.Row, SUMcols(i)) = CDbl(Cells(cell.Row, SUMcols(i))) + CDbl(Cells(Search.Row, SUMcols(i)))
        Next i                          '### go ahead to the next column
               
        Search.EntireRow.Delete         '### we are finished with this row. Delete the whole row
        Set Search = searchrange.Find(cell, after:=cell)    '### and search the next dublicate after our starting row
    Loop
 
Next                                    '### from here we start over with the next cell of our searchrange


                                        '### Note: This is a NEW unique value since we already deleted all old dublicates


Application.ScreenUpdating = True '### re-enable our screen updating
End Sub

 

[pbornemeier]

This works quickly to sum I:K of the rows with duplicates in column B.
it copies the original worksheet

Option Explicit

Sub SumIJKForDupesInB()
'
' Macro1 Macro
'
    Dim rngAF As Range
    Dim lRowIndex As Long
    Dim lAreaIndex As Long
    Dim lUniqueIndex As Long
    Dim lSheetRow As Long
    Dim lSummingRow As Long
    Dim aryColumnBUniques As Variant
    Dim iColumn As Long
    Dim sngI As Single
    Dim sngJ As Single
    Dim sngK As Single
    Dim iAnswer As VbMsgBoxResult
    Dim sActiveSheet As String
    
    'Save copy of current worksheet
    sActiveSheet = ActiveSheet.Name
    Worksheets.Add(After:=Sheets(sActiveSheet)).Name = sActiveSheet & "_Orig"
    
    'Work with the one wothout _Orig at end
    Worksheets(sActiveSheet).Select
    
    'Get column B Uniques
    aryColumnBUniques = ReturnUniquesInColumn(2)
    
    RevealRows 'Remove any filtered/hidden rows
    
    'Filter for each unique
    For lUniqueIndex = LBound(aryColumnBUniques, 1) To UBound(aryColumnBUniques, 1)
        lSummingRow = 0: sngI = 0: sngJ = 0: sngK = 0
        ActiveSheet.Range("$A$1").CurrentRegion.AutoFilter Field:=2, _
            Criteria1:="=" & aryColumnBUniques(lUniqueIndex, 1)
        Set rngAF = ActiveSheet.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
        For lAreaIndex = 1 To rngAF.Areas.Count
            'Debug.Print lAreaIndex,
            For lRowIndex = 1 To rngAF.Areas(lAreaIndex).Rows.Count
                'Debug
                lSheetRow = rngAF.Areas(lAreaIndex).Rows(lRowIndex).Row 'Row on sheet being checked
                If lSheetRow <> 1 Then              'Not looking at header row
                    If lSummingRow = 0 Then lSummingRow = lSheetRow        'First row for that unique
                    sngI = sngI + Cells(lSheetRow, 9).Value
                    sngJ = sngJ + Cells(lSheetRow, 10).Value
                    sngK = sngK + Cells(lSheetRow, 11).Value
                    If lSheetRow <> lSummingRow Then
                        Cells(lSheetRow, 1).Interior.Color = vbRed  'mark rows for deletion
                    End If
                End If
            Next
            'Debug.Print
        Next
        If lSummingRow <> 0 Then
            Cells(lSummingRow, 9).Value = sngI
            Cells(lSummingRow, 10).Value = sngJ
            Cells(lSummingRow, 11).Value = sngK
        End If
    Next
    Set rngAF = Nothing
    
    RevealRows 'Remove any filtered/hidden rows
    
    'Option to delete red rows
    With ActiveSheet
        .Range("$A$1").CurrentRegion.AutoFilter Field:=1, Criteria1:=vbRed, _
            Operator:=xlFilterCellColor
        If Application.WorksheetFunction.Subtotal(3, .Columns(1)) > 1 Then
            iAnswer = MsgBox("Do you want to delete duplicate rows used to calculate new totals?", vbYesNo, "Delete Duplicates?")
            If iAnswer = vbYes Then
                .Range("$A$1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells.Delete
            End If
        End If
    End With
    
    RevealRows 'Remove any filtered/hidden rows
    
End Sub

Sub RevealRows()

    With ActiveSheet
        If .FilterMode Then .ShowAllData    'Unfilters rows hidden by Autofilter/Advanced Filter
        .AutoFilterMode = False             'Turns off Autofilter DropDown Arrows
        .Rows.Hidden = False                'UnHides Rows
    End With

End Sub
Function ReturnUniquesInColumn(lColumn As Integer) As Variant
    'Return an array containing all unique items in the specified column
    '  on the ActiveSheet (ignores row 1)
    
    Dim varColData As Variant
    Dim lRowIndex As Long
    
    With ActiveSheet
        .AutoFilterMode = False
        If .FilterMode Then .ShowAllData
        .Rows.Hidden = False
    End With
    varColData = Range(Cells(2, lColumn), Cells(Cells(Rows.Count, lColumn).End(xlUp).Row, lColumn)).Value
    With CreateObject("Scripting.Dictionary")
        For lRowIndex = 1 To UBound(varColData, 1)
             .Item(varColData(lRowIndex, 1)) = Empty 'defines the SD .Key value & sets the .Item property to Empty
        Next
        If .Count > 0 Then
            ReturnUniquesInColumn = Application.Transpose(.Keys)
        End If
    End With

End Function