Macro to search multiple sheets for a value, move results to another sheet depending on inputted data

[LauraC1984]

Hi,
using the input sheet, I need to be able to search for a value in B13 - across multiple sheets - once the value is found. I need the macro to cut the row, and paste it into the sheet name entered into cell C13.
am I best doing this as separate macros, do one that finds and cuts the data and then others to run depending on the value in C13? as the data in c13 could be upto 14 different values/ 14 sheets that it might need pasting onto.
I can do the first bit of the macro, the find value - but then not sure on the coding for cut and paste - and the go to sheet ??? depending on value in c13

Thanks!
Laura

 

[My Aswer Is This]

You said:
Quote
across multiple sheets
Unquote
We need to know exactly what sheets.
And you said:
Quote
I need to be able to search for a value in B1 but did not say what value to search for
Unquote

 

[LauraC1984]

Hi
the value in B13 will be a 6 digit number
my other search macros start off as follows, I think its the section I have turned red that I will need to change once the value is found ...

Sub updateJobstatus()
Dim fn As Range, i As Long, sh As Worksheet, adr As String, cnt As Long
Set sh = Sheets("Input")
chg = True
Dim ssh As Worksheet
For Each ssh In ThisWorkbook.Sheets
If ssh.Name <> "Input" And ssh.Name <> "Calendar" And _
ssh.Name <> "List" And ssh.Name <> "2020" Then
ssh.Visible = True
Set fn = ssh.Range("C:C").Find(sh.Range("B11").Value, , xlValues, xlWhole)
If Not fn Is Nothing Then
adr = fn.Address
Do
ssh.Range("L" & fn.Row) = sh.Range("C11").Value
Set fn = ssh.Range("C:C").FindNext(fn)
Loop While adr <> fn.Address
End If
If fn Is Nothing Then
cnt = cnt + 1
End If
ssh.Visible = False
End If

 

[My Aswer Is This]

Hi
the value in B13 will be a 6 digit number
my other search macros start off as follows, I think its the section I have turned red that I will need to change once the value is found ...

Sub updateJobstatus()
Dim fn As Range, i As Long, sh As Worksheet, adr As String, cnt As Long
Set sh = Sheets("Input")
chg = True
Dim ssh As Worksheet
For Each ssh In ThisWorkbook.Sheets
If ssh.Name <> "Input" And ssh.Name <> "Calendar" And _
ssh.Name <> "List" And ssh.Name <> "2020" Then
ssh.Visible = True
Set fn = ssh.Range("C:C").Find(sh.Range("B11").Value, , xlValues, xlWhole)
If Not fn Is Nothing Then
adr = fn.Address
Do
ssh.Range("L" & fn.Row) = sh.Range("C11").Value
Set fn = ssh.Range("C:C").FindNext(fn)
Loop While adr <> fn.Address
End If
If fn Is Nothing Then
cnt = cnt + 1
End If
ssh.Visible = False
End If

Thank you for showing me the script you have.
But you did not answer either of my questions. I asked search for what and you said a six digit number. That is not specific enough. And I asked search what sheets and I saw no answer.
I like writing my own scripts instead of looking at user scripts and trying to modify them.
I'm sure someone else here on the forum will be able to help you. I will watch and see what I can learn.

 

[dmt32]

Hi,
bit of a guess but try running this code with your data & see if goes in right direction for you

Sub updateJobstatus()
    Dim FilterRange As Range, PasteRange As Range
    Dim FilterCount As Long, UsedRows As Long, FilterColumn As Long
    Dim sh As Worksheet, wsDestination As Worksheet
    Dim Search As String
    
    On Error GoTo myerror
    
    With Worksheets("Input")
'search vlaue
        Search = .Range("B13").Value
'paste destination sheet
        Set wsDestination = Worksheets(.Range("C13").Value)
    End With
    
'the column you are searching
    FilterColumn = 3
    
    For Each sh In ThisWorkbook.Worksheets
        Select Case sh.Name
        Case "Input", "Calendar", "List", "2020", wsDestination.Name
'do nothing
        Case Else
            sh.Visible = True
            sh.Range("A1").CurrentRegion.AutoFilter Field:=FilterColumn, Criteria1:=Search
            
            Set FilterRange = sh.AutoFilter.Range
'count filter records
            FilterCount = FilterRange.Columns(FilterColumn).SpecialCells(xlCellTypeVisible).Count - 1
            
            If FilterCount > 0 Then
                With wsDestination
                    UsedRows = WorksheetFunction.CountA(.Cells)
'remove header row
                    If UsedRows > 0 Then Set FilterRange = FilterRange.Offset(1, 0).Resize(FilterRange.Rows.Count - 1)
                    Set PasteRange = .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row + IIf(UsedRows = 0, 0, 1), 1)
                End With
                
                With FilterRange
                    With .SpecialCells(xlCellTypeVisible)
'copy filter record(s) to desination sheet
                        .Copy PasteRange
'delete filtered record(s)
                        .EntireRow.Delete xlShiftUp
                    End With
'clear filter
                    .AutoFilter
                End With
            End If
            
'clear object variables from memory
            Set PasteRange = Nothing
            Set FilterRange = Nothing
            
        End Select
        Next sh
        
myerror:
        If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

I have added comments in code so hopefully you can adjust it to meet specific need as required

Dave

 

[LauraC1984]

Hi,
Thanks I will try this now. i'm just checking the line
Case "Input", "Calendar", "List", "2020", wsDestination.Name
does that search only these sheets or are these the sheets not to be search? as in my other code, these sheets are not to be searched but all others are

Thanks

 

[dmt32]

Hi,
Thanks I will try this now. i'm just checking the line
Case "Input", "Calendar", "List", "2020", wsDestination.Name
does that search only these sheets or are these the sheets not to be search? as in my other code, these sheets are not to be searched but all others are

Thanks

Hi,
as commented in code, those sheets are all excluded (do nothing) which includes the name of the sheet specified as destination sheet

Hope solution helps

Dave

 

[LauraC1984]

ok that worked in terms of finding and moving the row, thank you, however I need it to
- put column A back into ascending order on the sheet that its moved the row to
- hide all sheets it has searched - as these were hidden before the macro but not hidden after

Thank you!

 

[LauraC1984]

Also can I add a message at the end to say if it was successful or not?

 

[dmt32]

try this update

Sub updateJobstatus()
    Dim FilterRange As Range, PasteRange As Range
    Dim FilterCount As Long, UsedRows As Long, FilterColumn As Long
    Dim sh As Worksheet, wsDestination As Worksheet
    Dim Search As String, msg As String
    
    On Error GoTo myerror
    
    With Worksheets("Input")
'search value
        Search = .Range("B13").Value
'paste destination sheet
        Set wsDestination = Worksheets(.Range("C13").Value)
    End With
    
'the column you are searching
    FilterColumn = 3
    
    For Each sh In ThisWorkbook.Worksheets
        Select Case sh.Name
        Case "Input", "Calendar", "List", "2020", wsDestination.Name
'do nothing
        Case Else
            sh.Visible = True
            sh.Range("A1").CurrentRegion.AutoFilter Field:=FilterColumn, Criteria1:=Search
            
            Set FilterRange = sh.AutoFilter.Range
'count filter records
            FilterCount = FilterRange.Columns(FilterColumn).SpecialCells(xlCellTypeVisible).Count - 1
            
            If FilterCount > 0 Then
                With wsDestination
                    UsedRows = WorksheetFunction.CountA(.Cells)
'remove header row
                    If UsedRows > 0 Then Set FilterRange = FilterRange.Offset(1, 0).Resize(FilterRange.Rows.Count - 1)
                    Set PasteRange = .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row + IIf(UsedRows = 0, 0, 1), 1)
                End With
                
                With FilterRange
                    With .SpecialCells(xlCellTypeVisible)
'copy filter record(s) to desination sheet
                        .Copy PasteRange
'delete filtered record(s)
                        .EntireRow.Delete xlShiftUp
                    End With
'clear filter
                    .AutoFilter
                End With
                msg = msg & sh.Name & Chr(10)
            End If
            
            sh.Visible = xlSheetHidden
            
'clear object variables from memory
            Set PasteRange = Nothing
            Set FilterRange = Nothing
            
        End Select
        Next sh
        
myerror:
        If Err <> 0 Then
'report errors
            MsgBox (Error(Err)), 48, "Error"
        Else
            If Len(msg) > 0 Then
                MsgBox "Following Sheets Where Copied" & Chr(10) & msg, 48, "Success"
            Else
                MsgBox "No Matches Found", 48, "Not Records Found"
            End If
        End If
End Sub

Sorry but do not follow bit about "Put Column A Back Into Ascending Order"?
Code should filter & copy in same order as in the the worksheets

Dave