Copy row if cell contains specific word

[asaf27064]

Heĺlo
I have 2 sheets with one table in each of them. The sheets names is "Work" and "Bank".
In each table I want to copy the whole row in the table if cell in column B contain the word "Exist" and move it to a sheet in a new excel file (workbook) under the name of the relevant sheet.

 

[NMa91]

Add below code to your input file where sheets namely work bank Total exists. You should not get subscript out of range error if all sheets are there. In order to auto update the changes, you would need fix reference of the file. Here, we create new file containing "Exist" rows.

Sub CopyRow()
Dim arr() As Variant
Dim lRow As Long, sht As Worksheet, wb As Workbook, eRow As Long




arr = Array("Work", "Bank", "Total")
Set wb = Workbooks.Add
wb.Sheets(1).Name = "Work"


If wb.Sheets.Count = 1 Then
    wb.Sheets.Add
    wb.Sheets.Add
ElseIf wb.Sheets.Count = 2 Then
    wb.Sheets.Add
End If
 
wb.Sheets(2).Name = "Bank"
wb.Sheets(3).Name = "Total"
    


For j = LBound(arr) To UBound(arr)
    Set sht = ThisWorkbook.Sheets(arr(j))
    lRow = sht.Range("A" & Rows.Count).End(xlUp).Row
    eRow = wb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
    For i = 1 To lRow
        If sht.Range("B" & i) = "Exist" Then sht.Range("B" & i).EntireRow.Copy wb.Sheets(arr(j)).Range("A" & eRow)
        lRow = sht.Range("A" & Rows.Count).End(xlUp).Row
        eRow = wb.Sheets(arr(j)).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
    Next i
Next j




End Sub

 

[asaf27064]

Add below code to your input file where sheets namely work bank Total exists. You should not get subscript out of range error if all sheets are there. In order to auto update the changes, you would need fix reference of the file. Here, we create new file containing "Exist" rows.

Sub CopyRow()
Dim arr() As Variant
Dim lRow As Long, sht As Worksheet, wb As Workbook, eRow As Long




arr = Array("Work", "Bank", "Total")
Set wb = Workbooks.Add
wb.Sheets(1).Name = "Work"


If wb.Sheets.Count = 1 Then
    wb.Sheets.Add
    wb.Sheets.Add
ElseIf wb.Sheets.Count = 2 Then
    wb.Sheets.Add
End If
 
wb.Sheets(2).Name = "Bank"
wb.Sheets(3).Name = "Total"
    


For j = LBound(arr) To UBound(arr)
    Set sht = ThisWorkbook.Sheets(arr(j))
    lRow = sht.Range("A" & Rows.Count).End(xlUp).Row
    eRow = wb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
    For i = 1 To lRow
        If sht.Range("B" & i) = "Exist" Then sht.Range("B" & i).EntireRow.Copy wb.Sheets(arr(j)).Range("A" & eRow)
        lRow = sht.Range("A" & Rows.Count).End(xlUp).Row
        eRow = wb.Sheets(arr(j)).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
    Next i
Next j




End Sub

Hi
Thank you very much for your help but its still showing error 9
here my file:
http://www.mediafire.com/file/s12azbgqv98vt1q/new.xlsm

 

[Fluff]

Try this mod to NMa91's code

Sub CopyRow()
Dim arr() As Variant
Dim lRow As Long, sht As Worksheet, wb As Workbook, eRow As Long

arr = Array("Work", "Bank", "Total")
Set wb = Workbooks.Add

If wb.Sheets.Count = 1 Then
    wb.Sheets.Add
    wb.Sheets.Add
ElseIf wb.Sheets.Count = 2 Then
    wb.Sheets.Add
End If

wb.Sheets(1).Name = "Work"
wb.Sheets(2).Name = "Bank"
wb.Sheets(3).Name = "Total"

For j = LBound(arr) To UBound(arr)
    Set sht = ThisWorkbook.Sheets(arr(j))
    lRow = sht.Range("A" & Rows.Count).End(xlUp).Row
    eRow = wb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
    For i = 1 To lRow
        If sht.Range("B" & i) = "Exist" Then sht.Range("B" & i).EntireRow.Copy wb.Sheets(arr(j)).Range("A" & eRow)
        lRow = sht.Range("A" & Rows.Count).End(xlUp).Row
        eRow = wb.Sheets(arr(j)).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
    Next i
Next j

End Sub

 

[asaf27064]

Try this mod to NMa91's code

Sub CopyRow()
Dim arr() As Variant
Dim lRow As Long, sht As Worksheet, wb As Workbook, eRow As Long

arr = Array("Work", "Bank", "Total")
Set wb = Workbooks.Add

If wb.Sheets.Count = 1 Then
    wb.Sheets.Add
    wb.Sheets.Add
ElseIf wb.Sheets.Count = 2 Then
    wb.Sheets.Add
End If

wb.Sheets(1).Name = "Work"
wb.Sheets(2).Name = "Bank"
wb.Sheets(3).Name = "Total"

For j = LBound(arr) To UBound(arr)
    Set sht = ThisWorkbook.Sheets(arr(j))
    lRow = sht.Range("A" & Rows.Count).End(xlUp).Row
    eRow = wb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
    For i = 1 To lRow
        If sht.Range("B" & i) = "Exist" Then sht.Range("B" & i).EntireRow.Copy wb.Sheets(arr(j)).Range("A" & eRow)
        lRow = sht.Range("A" & Rows.Count).End(xlUp).Row
        eRow = wb.Sheets(arr(j)).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
    Next i
Next j

End Sub

Thank you its working but i want the output files to create tables with the same coulmns names
and to be automatically updated every time i open it
like in this file:
http://www.mediafire.com/file/pg5znqmbpj7ogfu/output.xlsx

it is possible to put the vba code on the output file and then it will take the value from the original file?

Thank you very much!

 

[asaf27064]

Can you help me?
I uploaded the output file like I want it to be

 

[NMa91]

I suggest that instead of creating new file with every code run, let's save output file once and all with above code. Once we run the code, it would open input file from the same drive, pick exist row data and close input file. Whenever you open output file, it can update the data as required.

 

[asaf27064]

I suggest that instead of creating new file with every code run, let's save output file once and all with above code. Once we run the code, it would open input file from the same drive, pick exist row data and close input file. Whenever you open output file, it can update the data as required.

So I just copy the code to the output file and save it then every time I open the file it will update automatically?

 

[NMa91]

This is a solution, If you agree, I will build the code accordingly.

 

[asaf27064]

This is a solution, If you agree, I will build the code accordingly.

Yes I agree and i will appreciate if you build it
But I want it to output tables with the same columns as the original workbook please

Thank you

 

[asaf27064]

This is a solution, If you agree, I will build the code accordingly.

Hey
Do you have the formula?