Please test my code to find out the problem

R

Ramadan

Board Regular
Joined
Jan 20, 2024
Messages
168
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
Try.
VBA Code: 
Sub SearchMultipleSheets()
Application.ScreenUpdating = False
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
Application.ScreenUpdating = True
End Sub
 
Upvote 0
kvsrinivasamurthy said:
Try.
VBA Code: 
Sub SearchMultipleSheets()
Application.ScreenUpdating = False
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
Application.ScreenUpdating = True
End Sub
Click to expand...
@kvsrinivasamurthy Still the same problem freezing all excel files for more than 4 minutes untill I forced all excel files to be closed
 
Upvote 0
Ramadan said:
can we make the code add the sheet name in front of each result in Column B
Click to expand...
Ok, try small modification
VBA Code: 
                    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
                        
                        ' Insert the sheet name into the column "B"
                        Paste_Cell.Value = sheetName

                        ' 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
 
Upvote 0
MikeVol said:
Ok, try small modification
VBA Code: 
                    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
                      
                        ' Insert the sheet name into the column "B"
                        Paste_Cell.Value = sheetName

                        ' 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
Click to expand...

MikeVol said:
Ok, try small modification
VBA Code: 
                    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
                       
                        ' Insert the sheet name into the column "B"
                        Paste_Cell.Value = sheetName

                        ' 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
Click to expand...
@MikeVol Wow that's really GREAT it works very very good and very fast .. I really appreciate your help thank you so much bro
 
Upvote 0
@MikeVol I just need to stop the code from resizing the cells every new search, just to copy the data and keep cell size and format of the "test" sheet cells
I thought that it might be in this line (Paste_Cell.Resize(1, 20).Value = sh.Range(sh.Cells(Found.Row, 1), sh.Cells(Found.Row, 20)).Value...) if I removed Resize 😂 but it's not
what should i do in the code to do that?
 
Upvote 0
Okay @Ramadan, one more small code modification. But that's it.
VBA Code: 
    ' Clear previous results starting from B9
    Paste_Cell.Resize(ThisWorkbook.Sheets("test").Rows.Count - Paste_Cell.Row + 1, 20).Clear
    '    Paste_Cell.Resize(ThisWorkbook.Sheets("test").Rows.Count - Paste_Cell.Row + 1, 20).ClearContents
and
VBA Code: 
                    Do

                        ' Copy the entire row (A:T)
                        sh.Range(sh.Cells(Found.Row, 1), sh.Cells(Found.Row, 20)).Copy

                        ' Paste the data and save the formatting
                        With Paste_Cell
                            .PasteSpecial Paste:=xlPasteValues     ' Paste only values
                            .PasteSpecial Paste:=xlPasteFormats    ' Paste cell formats
                        End With

                        ' Insert the sheet name into the column "B"
                        Paste_Cell.Value = sheetName

                        ' Remove selection from clipboard
                        Application.CutCopyMode = False

                        ' 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
and
VBA Code: 
    If Not iFound Then
        MsgBox "Nothing found."
    Else

        '        ' Apply AutoFit to the columns after pasting
        '        ThisWorkbook.Worksheets("test").Columns("B:T").AutoFit
    End If
Good luck.
 
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
385
who am i
W
R
  • Solved
My code to capitalize first letter duplicates the letter
Replies
9
Views
184
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
354
NdNoviceHlp
NdNoviceHlp
C
  • Question Question
Please help clean up my convoluted VBA code. It seems very redundant and repetitive.
Replies
1
Views
491
myall_blues
myall_blues
C
  • Solved
Please help me clean up my VBA script, I'm having trouble with redundancies
Replies
4
Views
499
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