Please test my code to find out the problem

R

Ramadan

Board Regular
Joined
Jan 20, 2024
Messages
169
Office Version
  1. 2021
Platform
  1. Windows
Please professionals I need your help as I'm not well orriented with VBA complicated issues

I have found a good VBA code to search value across multiple sheets and adjusted it to be combitable with my workbook and it seems ok but unfortunately doesn't give me any results or even errors and I don't know what is the probelm. I use "test" sheet in the workbook to be my search sheets and the code module in the workbook is (Module 8)

herein below I shared a copy from my file including the code (Module 8) and also shared the video link that I found and it explain how the worde works in details

I'm sure this will help alot of excel users that are looking for the same issue as I have spend weeks looking for such code

this is the code
VBA Code: 
Sub SearchMultipleSheets()

Main_Sheet = "test"
Search_Cell = "B5"
SearchType_Cell = "C5"
Paste_Cell = "B9"

Searched_Sheets = Array("District1", "Carnell", "Ivory", "West", "GoldC", "KingsRange", "Amberville", "KingsRange2")
Searched_Ranges = Array("D:M", "D:M", , "D:M", "D:M", "D:M", "D:M", "D:M", "D:M")

Copy_Format = True

Last_Row = Sheets(Main_Sheet).Range(Paste_Cell).End(xlDown).Row
Last_Column = Sheets(Main_Sheet).Range(Paste_Cell).End(xlToRight).Column
Set Used_Range = Sheets(Main_Sheet).Range(Cells(Range(Paste_Cell).Row, Range(Paste_Cell).Column), Cells(Last_Row, Last_Column))
Used_Range.ClearContents
Used_Range.ClearFormats

Value1 = Sheets(Main_Sheet).Range(Search_Cell).Value
Count = -1

If Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case-Sensitive" Then
    Case_Sensitive = True
ElseIf Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case-Insensitive" Then
    Case_Sensitive = False
Else
    MsgBox ("Choose a Search Type.")
    Exit Sub
End If

For S = LBound(Searched_Sheets) To UBound(Searched_Sheets)
    Set rng = Sheets(Searched_Sheets(S)).Range(Searched_Ranges(S))
    For i = 1 To rng.Rows.Count
        For j = 1 To rng.Columns.Count
            Value2 = rng.Cells(i, j).Value
            If PartialMatch(Value1, Value2, Case_Sensitive) = True Then
                Count = Count + 1
                rng.Rows(i).Copy
                Set Paste_Range = Sheets(Main_Sheet).Cells(Range(Paste_Cell).Row + Count, Range(Paste_Cell).Column)
                If Copy_Format = True Then
                    Paste_Range.PasteSpecial Paste:=xlPasteAll
                Else
                    Paste_Range.PasteSpecial Paste:=xlPasteValues
                End If
            End If
        Next j
    Next i
Next S

Application.CutCopyMode = False

End Sub

Function PartialMatch(Value1, Value2, Case_Sensitive)

Matched = False
For i = 1 To Len(Value2)
    If Case_Sensitive = True Then
        If Mid(Value2, i, Len(Value1)) = Value1 Then
            Matched = True
            Exit For
        End If
    Else
        If Mid(LCase(Value2), i, Len(Value1)) = LCase(Value1) Then
            Matched = True
            Exit For
        End If
    End If
Next i

PartialMatch = Matched

End Function

thank you in advance for your help

this is my file link

files.fm

xlsm: AUTHs - Copy.xlsm

Visit this link to download: AUTHs - Copy.xlsm
files.fm files.fm

here is the viedo explaining how the code works

 
Sort by date Sort by votes
Hello @Ramadan.
Try another variant
VBA Code: 
Option Explicit

Sub SearchMultipleSheets_v2()
    Dim Found       As Range
    Dim firstAddress As String
    Dim sh          As Worksheet
    Dim Case_Sensitive As Boolean
    Dim sheetName   As Variant
    Dim lastrow     As Long

    Dim Search      As Variant
    Search = ThisWorkbook.Worksheets("test").Range("B5").Value
    If Search = "" Then Exit Sub
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Get search type from cell C5 on the "test" sheet (dropdown list)
    Dim SearchType_Cell As String
    SearchType_Cell = ThisWorkbook.Worksheets("test").Range("C5").Value

    If SearchType_Cell = "Case Sensitive" Then
        Case_Sensitive = True
    Else
        Case_Sensitive = False
    End If

    Dim Paste_Cell  As Range
    Set Paste_Cell = ThisWorkbook.Worksheets("test").Range("B9")

    ' Clear previous results starting from B9
    Paste_Cell.Resize(ThisWorkbook.Sheets("test").Rows.Count - Paste_Cell.Row + 1, 20).ClearContents

    Dim Searched_Sheets As Variant
    Searched_Sheets = Array("District1", "Carnell", "Ivory", "West", "GoldC", "KingsRange", "Amberville", "KingsRange2")

    Dim iFound      As Boolean
    iFound = False

    ' Loop through the sheets in Searched_Sheets array
    For Each sheetName In Searched_Sheets
        
        On Error Resume Next
        Set sh = ThisWorkbook.Sheets(sheetName)
        On Error GoTo 0

        ' Only search if the sheet exists
        If Not sh Is Nothing Then

            With sh.UsedRange
                lastrow = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
                Set Found = sh.Range("B10:T" & lastrow).Find(Search, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=Case_Sensitive)

                If Not Found Is Nothing Then
                    iFound = True
                    firstAddress = Found.Address

                    Do

                        ' Copy the entire row from columns A to T
                        Paste_Cell.Resize(1, 20).Value = sh.Range(sh.Cells(Found.Row, 1), sh.Cells(Found.Row, 20)).Value

                        ' Move to the next row in the "test" sheet
                        Set Paste_Cell = Paste_Cell.Offset(1, 0)

                        Set Found = .FindNext(Found)
                    Loop While Not Found Is Nothing And Found.Address <> firstAddress
                End If

            End With

        End If

    Next

    If Not iFound Then
        MsgBox "Nothing found."
    Else

        ' Apply AutoFit to the columns after pasting
        ThisWorkbook.Worksheets("test").Columns("B:T").AutoFit
    End If

    Set Found = Nothing
    Set Paste_Cell = Nothing
    Set Found = Nothing
    Set sh = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
There was a "Case-Sensitive" and "Case-Insensitive" error in your code, namely in the dash (-), it was unnecessary. There should have been a space. And the code itself took a long time to work. I hope I was able to help you. Good luck.
 
Upvote 0
Solution
I have made some corrections in code. Tried working ok.
VBA Code: 
Sub SearchMultipleSheets()

Main_Sheet = "test"
Search_Cell = "B5"
SearchType_Cell = "C5"
Paste_Cell = "B9"

Searched_Sheets = Array("District1", "Carnell", "Ivory", "West", "GoldC", "KingsRange", "Amberville", "KingsRange2")
Searched_Ranges = Array("D:M", "D:M", "D:M", "D:M", "D:M", "D:M", "D:M", "D:M", "D:M")

Copy_Format = True

Last_Row = Sheets(Main_Sheet).Range(Paste_Cell).End(xlDown).Row
Last_Column = Sheets(Main_Sheet).Range(Paste_Cell).End(xlToRight).Column
Set Used_Range = Sheets(Main_Sheet).Range(Cells(Range(Paste_Cell).Row, Range(Paste_Cell).Column), Cells(Last_Row, Last_Column))
Used_Range.ClearContents
Used_Range.ClearFormats

Value1 = Sheets(Main_Sheet).Range(Search_Cell).Value
Count = -1

If Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case Sensitive" Then
    Case_Sensitive = True
ElseIf Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case Insensitive" Then
    Case_Sensitive = False
Else
    MsgBox ("Choose a Search Type.")
    Exit Sub
End If

For S = LBound(Searched_Sheets) To UBound(Searched_Sheets)
    Set Rng = Sheets(Searched_Sheets(S)).Range(Searched_Ranges(S))
    For i = 1 To Rng.Rows.Count
        For j = 1 To Rng.Columns.Count
            Value2 = Rng.Cells(i, j).Value
            If PartialMatch(Value1, Value2, Case_Sensitive) = True Then
                Count = Count + 1
                Rng.Rows(i).Copy
                Set Paste_Range = Sheets(Main_Sheet).Cells(Range(Paste_Cell).Row + Count, Range(Paste_Cell).Column)
                If Copy_Format = True Then
                    Paste_Range.PasteSpecial Paste:=xlPasteAll
                Else
                    Paste_Range.PasteSpecial Paste:=xlPasteValues
                End If
            End If
        Next j
    Next i
Next S

Application.CutCopyMode = False

End Sub
Corrected lines.

Searched_Ranges = Array("D:M", "D:M", "D:M", "D:M", "D:M", "D:M", "D:M", "D:M", "D:M")

If Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case Sensitive" Then

ElseIf Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case Insensitive" Then
 
Upvote 0
MikeVol said:
Hello @Ramadan.
Try another variant
VBA Code: 
Option Explicit

Sub SearchMultipleSheets_v2()
    Dim Found       As Range
    Dim firstAddress As String
    Dim sh          As Worksheet
    Dim Case_Sensitive As Boolean
    Dim sheetName   As Variant
    Dim lastrow     As Long

    Dim Search      As Variant
    Search = ThisWorkbook.Worksheets("test").Range("B5").Value
    If Search = "" Then Exit Sub
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Get search type from cell C5 on the "test" sheet (dropdown list)
    Dim SearchType_Cell As String
    SearchType_Cell = ThisWorkbook.Worksheets("test").Range("C5").Value

    If SearchType_Cell = "Case Sensitive" Then
        Case_Sensitive = True
    Else
        Case_Sensitive = False
    End If

    Dim Paste_Cell  As Range
    Set Paste_Cell = ThisWorkbook.Worksheets("test").Range("B9")

    ' Clear previous results starting from B9
    Paste_Cell.Resize(ThisWorkbook.Sheets("test").Rows.Count - Paste_Cell.Row + 1, 20).ClearContents

    Dim Searched_Sheets As Variant
    Searched_Sheets = Array("District1", "Carnell", "Ivory", "West", "GoldC", "KingsRange", "Amberville", "KingsRange2")

    Dim iFound      As Boolean
    iFound = False

    ' Loop through the sheets in Searched_Sheets array
    For Each sheetName In Searched_Sheets
       
        On Error Resume Next
        Set sh = ThisWorkbook.Sheets(sheetName)
        On Error GoTo 0

        ' Only search if the sheet exists
        If Not sh Is Nothing Then

            With sh.UsedRange
                lastrow = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
                Set Found = sh.Range("B10:T" & lastrow).Find(Search, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=Case_Sensitive)

                If Not Found Is Nothing Then
                    iFound = True
                    firstAddress = Found.Address

                    Do

                        ' Copy the entire row from columns A to T
                        Paste_Cell.Resize(1, 20).Value = sh.Range(sh.Cells(Found.Row, 1), sh.Cells(Found.Row, 20)).Value

                        ' Move to the next row in the "test" sheet
                        Set Paste_Cell = Paste_Cell.Offset(1, 0)

                        Set Found = .FindNext(Found)
                    Loop While Not Found Is Nothing And Found.Address <> firstAddress
                End If

            End With

        End If

    Next

    If Not iFound Then
        MsgBox "Nothing found."
    Else

        ' Apply AutoFit to the columns after pasting
        ThisWorkbook.Worksheets("test").Columns("B:T").AutoFit
    End If

    Set Found = Nothing
    Set Paste_Cell = Nothing
    Set Found = Nothing
    Set sh = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
There was a "Case-Sensitive" and "Case-Insensitive" error in your code, namely in the dash (-), it was unnecessary. There should have been a space. And the code itself took a long time to work. I hope I was able to help you. Good luck.
Click to expand...
@MikeVol Thank you soooo much I do really appreciate your great help, now it works perfectly. just please if possible one simple issue, can we make the code add the sheet name in front of each result in Column B as you can see in the below image to let me know in which sheet this result is found? Or I have in cell "$B$2" in each sheet a code for the sheet name if it can be added in col "B" in front of each result would be GREAT.. I tried to use this formula to get the sheet code in cell B2 but it's not giving me accurate result =IF(COUNTIFS(District1!B:B,D14,District1!C:C,E14)>0,District1!$B$2,IF(COUNTIFS('Carnell'!B:B,D14,'Carnell'!C:C,E14)>0,'Carnell'!$B$2, etc...

and really thank you so much for this effort
Untitled.png
 
Upvote 0
kvsrinivasamurthy said:
I have made some corrections in code. Tried working ok.
VBA Code: 
Sub SearchMultipleSheets()

Main_Sheet = "test"
Search_Cell = "B5"
SearchType_Cell = "C5"
Paste_Cell = "B9"

Searched_Sheets = Array("District1", "Carnell", "Ivory", "West", "GoldC", "KingsRange", "Amberville", "KingsRange2")
Searched_Ranges = Array("D:M", "D:M", "D:M", "D:M", "D:M", "D:M", "D:M", "D:M", "D:M")

Copy_Format = True

Last_Row = Sheets(Main_Sheet).Range(Paste_Cell).End(xlDown).Row
Last_Column = Sheets(Main_Sheet).Range(Paste_Cell).End(xlToRight).Column
Set Used_Range = Sheets(Main_Sheet).Range(Cells(Range(Paste_Cell).Row, Range(Paste_Cell).Column), Cells(Last_Row, Last_Column))
Used_Range.ClearContents
Used_Range.ClearFormats

Value1 = Sheets(Main_Sheet).Range(Search_Cell).Value
Count = -1

If Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case Sensitive" Then
    Case_Sensitive = True
ElseIf Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case Insensitive" Then
    Case_Sensitive = False
Else
    MsgBox ("Choose a Search Type.")
    Exit Sub
End If

For S = LBound(Searched_Sheets) To UBound(Searched_Sheets)
    Set Rng = Sheets(Searched_Sheets(S)).Range(Searched_Ranges(S))
    For i = 1 To Rng.Rows.Count
        For j = 1 To Rng.Columns.Count
            Value2 = Rng.Cells(i, j).Value
            If PartialMatch(Value1, Value2, Case_Sensitive) = True Then
                Count = Count + 1
                Rng.Rows(i).Copy
                Set Paste_Range = Sheets(Main_Sheet).Cells(Range(Paste_Cell).Row + Count, Range(Paste_Cell).Column)
                If Copy_Format = True Then
                    Paste_Range.PasteSpecial Paste:=xlPasteAll
                Else
                    Paste_Range.PasteSpecial Paste:=xlPasteValues
                End If
            End If
        Next j
    Next i
Next S

Application.CutCopyMode = False

End Sub
Corrected lines.

Searched_Ranges = Array("D:M", "D:M", "D:M", "D:M", "D:M", "D:M", "D:M", "D:M", "D:M")

If Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case Sensitive" Then

ElseIf Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case Insensitive" Then
Click to expand...
@kvsrinivasamurthy Thank you so much for your help but I get error as attached in the below iamge
Untitled.png
 
Upvote 0
@kvsrinivasamurthy It works now but unfortunately with slow performance as it drops rows one after one not all at once and makes the excel file freeze and also starting collected data from col D in the sheets table not col B ** anyway thank you so much I do appreciate your help but will go with @MikeVol suggestion as it much faster and drop all results at once with starting from col B
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Solved
Looking For Tips To Improve My VBA
Replies
8
Views
393
who am i
W
R
  • Solved
My code to capitalize first letter duplicates the letter
Replies
9
Views
186
Ramadan
R
C
  • Question Question
Finding the problem with the code that gives the message "The picture is too large and will be truncated" ...
2
Replies
14
Views
360
NdNoviceHlp
NdNoviceHlp
C
  • Question Question
Please help clean up my convoluted VBA code. It seems very redundant and repetitive.
Replies
1
Views
493
myall_blues
myall_blues
C
  • Solved
Please help me clean up my VBA script, I'm having trouble with redundancies
Replies
4
Views
506
CapRavOr
C

Share this page

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