Search text on all Worksbooks and Copy Paste entire Row (Help on Merged Cells)

[paulcherianc]

Hi,

I was developing a macro to search the user given text on any cell and if found copy paste entire row from Column A till the end of that particular row to a new sheet on the macro workbook. I think its working except on the merged fields.

Can any experts help me to sort it out.

Macro should copy the the relative merged rows also.

If needed i shall add a sample macro file and a sample data file. Please help me to fix this.

Sub SearchFolders()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    Dim wOut As Worksheet
    Dim wks As Worksheet
    Dim rFound As Range
    Dim strFirstAddress As String
    Dim strSearch As String
    Const strPath As String = "C:\Users\Paul Cherian\Desktop\Samples\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir("*.xlsx*")
    strSearch = InputBox("Please enter the Search Term.")
    Set wOut = Worksheets.Add
    wOut.Range("A1:D1") = Array("Workbook", "Worksheet", "Cell", "Text in Cell")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            For Each wks In .Sheets
                Set rFound = wks.Range("A:Z").Find(strSearch, LookIn:=xlValues, lookat:=xlPart)
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                   
                 
                    Do
                        wOut.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = wkbSource.Name
                        wOut.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = wks.Name
                        wOut.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = rFound.Address
                        wOut.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) = rFound.Value
                        wks.Range(wks.Cells(rFound.Row, 1), wks.Cells(rFound.Row, wks.Cells(rFound.Row, wks.Columns.Count).End(xlToLeft).Column)).Copy wOut.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
                        Set rFound = wks.Range("A:Z").FindNext(rFound)
                    Loop While rFound.Address <> strFirstAddress
                    sAddr = ""
                End If
            Next wks
        End With
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[Derick Pitcher]

Hi,
I'm no VBA guru but working with merged cells are a pain and prone to errors. I had the same issue in my project. My fix was to unmerge the cells, Right click on the selected cells, choose 'Format Cells...', Choose the Alignment Tab, In the 'Horizontal:' Text alignment box choose 'Center Across Selection'. This way you can reference the same cell and not change your code.
This may or may not help but worth a try.