Microsoft Excel - Find Content name in Column A then copy entire row to master workbook

Asked By farrukh on 01-Sep-11 05:38 AM
Earn up to 20 extra points for answering this tough question.
HI All,

I need a code that find specific  test.xlsm (excel file) in a folder then content name in column A. If find content name "Hello" then copy the entire row to master.xlsm on A1 row ,Same like find content name "Welcome" in column A then Copy entire row to Master.xlsm Row A2.  I have to define many criteria in this code any one help me for just content names "Hello" and "Welcome".

Thanks,
Farrukh 
Jackpot . replied to farrukh on 01-Sep-11 01:26 PM
Hi Farrukh

Try the below code. You can add more words and adjust the range accordingly. I assume that the test.xlsm and master.xlsm files are closed and the activesheet contain the list of words to be searched...


Sub FindContentnameforFarukh()
Dim wb As Workbook, wbMaster As Workbook, rngFindList As Range
Dim lngRow As Long, cell As Range
  
Application.ScreenUpdating = False
  
Set rngFindList = ActiveSheet.Range("A1:A2") 'List of words you want to search
Set wb = Workbooks.Open("e:\test.xlsm")
Set wbMaster = Workbooks.Open("e:\master.xlsm")
  
For Each cell In wb.ActiveSheet.Range("A1:A" & _
wb.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row)
If Application.CountIf(rngFindList, cell.Text) Then
lngRow = lngRow + 1
wb.ActiveSheet.Rows(cell.Row).Copy wbMaster.ActiveSheet.Rows(lngRow)
End If
Next
  
wbMaster.Close True
wb.Close False
Application.ScreenUpdating = True
  
End Sub
farrukh replied to Jackpot . on 01-Sep-11 02:52 PM
Respected jack,

Sorry i if i did not write well to understand in original post. Jack the code works, but how can i search the content names, if find "Hello" in Column A in  test,xlsm then copy to master.xlsm in Column A Row 1 and if find "Welcome" in Column A in  test.xlsm then copy the entire row to master.xlsm column A row 2 and i have to define more words like
"Welcome back Jack good wishes" in test.xlsm in column A then copy entire row to master.xlsm Column A row number 3.

Need " HARD CODED" words 


Thanks and Regards,
Farrukh 

Pichart Y. replied to farrukh on 01-Sep-11 10:54 PM
Hi Farrukh,

I design here is...
1) The code will find all the files in the same folder
2) Open them, file by file, name it SourceWb in variable
3) Loop to check you criteria, which will be input in the sheet criteria of MasterWb
4) if find the criteria value, then copy all entire row and paste it to sheet master
5) Then close the file SourceWb, and loop to next file in the folder

I try to make this MasterWb flexible...only 2 conditions
  1 All the files concerned include the MasterWb must be located in same folder
  2 The sheet to be check must be 1sheet of each source file.

Here attachment for you to try ----> FindThenCopyXworkbook.zip

Hope this satisfy your requirement

----------------- code Here -------------------------------

Sub GetData()

    Application.DisplayAlerts = False
    On Error Resume Next
    Dim Directory As String, f As String
    Application.ScreenUpdating = False
   
    mainWb = ActiveWorkbook.Name
    Directory = ThisWorkbook.Path & "\"
    f = Dir(Directory)
    If f <> ThisWorkbook.Name Then
        Workbooks.Open Filename:=ThisWorkbook.Path & "\" & f
       
    sourceWb = ActiveWorkbook.Name
    Workbooks(mainWb).Activate
    Sheets("criteria").Select
    Range("A2").Select
   
    Do Until ActiveCell.Value = ""
    locCriteria = ActiveCell.Address
    selCriteria = ActiveCell.Value
   
    For Each cell In Workbooks(sourceWb).Sheets(1).Range("A1:A" & Workbooks(sourceWb).Sheets(1).Range("A" & Rows.Count).End(xlUp).Row)
    If cell.Value = selCriteria Then
    Workbooks(sourceWb).Sheets(1).Range(cell.Address).EntireRow.Copy
    Workbooks(mainWb).Sheets("master").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    End If
    Next
    Range(locCriteria).Offset(1, 0).Select
    Loop
Sheets("Master").Select
Workbooks(sourceWb).Close

   End If
  
    Do While f <> ""
      f = Dir
      If f <> "" And f <> ThisWorkbook.Name Then
        Workbooks.Open Filename:=ThisWorkbook.Path & "\" & f
       
    sourceWb = ActiveWorkbook.Name
    Workbooks(mainWb).Activate
    Sheets("criteria").Select
    Range("A2").Select
   
    Do Until ActiveCell.Value = ""
    locCriteria = ActiveCell.Address
    selCriteria = ActiveCell.Value
   
    For Each cell In Workbooks(sourceWb).Sheets(1).Range("A1:A" & Workbooks(sourceWb).Sheets(1).Range("A" & Rows.Count).End(xlUp).Row)
    If cell.Value = selCriteria Then
    Workbooks(sourceWb).Sheets(1).Range(cell.Address).EntireRow.Copy
    Workbooks(mainWb).Sheets("master").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    End If
    Next
    Range(locCriteria).Offset(1, 0).Select
    Loop
Sheets("Master").Select
Workbooks(sourceWb).Close

      End If
    Loop

    Application.ScreenUpdating = True
    Sheets("ConsoleArea").Range("A65536").End(xlUp).Offset(1, 0).Select
End Sub

--------------------------- End of Code -------------------------

Pichart Y.

Jackpot . replied to farrukh on 02-Sep-11 12:58 AM
Hi Farrukh

So you mean to say that you need to find whether specific words exists in text found in column A. Try the below version


Sub FindContentnameforFarukh()
Dim wb As Workbook, wbMaster As Workbook, rngFindList As Range
Dim lngRow As Long, cell As Range, rng As Range, blnFound As Boolean
    
Application.ScreenUpdating = False
    
Set rngFindList = ActiveSheet.Range("A1:A2") 'List of words you want to search
Set wb = Workbooks.Open("e:\test.xlsm")
Set wbMaster = Workbooks.Open("e:\master.xlsm")
    
For Each cell In wb.ActiveSheet.Range("A1:A" & _
wb.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row)
  blnFound = False
  For Each rng In rngFindList
  If Trim(rng.Text) <> "" Then
  If InStr(1, cell.Text, rng.Text, vbTextCompare) > 0 Then
  blnFound = True: Exit For
  End If
  End If
  Next
  
  If blnFound Then
  lngRow = lngRow + 1
  wb.ActiveSheet.Rows(cell.Row).Copy wbMaster.ActiveSheet.Rows(lngRow)
  End If
Next
    
wbMaster.Close True
wb.Close False
Application.ScreenUpdating = True
    
End Sub

farrukh replied to Jackpot . on 02-Sep-11 01:42 AM

Respected Jack & Pichart Y,

Your both codes worked for me awesome, that is exactly according to my need :)

Thanks you for your great support :)

Best Regards,
Farrukh