copy/paste row based on keyword

M

MikeWip

New Member
Joined
Feb 13, 2017
Messages
45
Hi guys,

wanna know if you guys could help me write vba code.
I have a file with 2 tabs. Tab 1: London Vigs Tab2: FILE
Ideally, I'd like all rows from tab 1 containing the wording: (DONE) in column A, to be copy/pasted onto tab 2 (FILE)

for instance

A1: car (DONE)
A2: bike (DONE)
A3: cylce
A4: bus

only row 1 & 2 should be copy/pasted onto tab2 because of the wording (DONE). data from row 3 & 4 are not copy/pasted.

thanks for your help dudes

Mike
 
Sort by date Sort by votes
Is this what your data looks like?


Excel 2010
A
1CARS
2CO: MERCEDES
3A class
4E Class (DONE)
5S Class (DONE)
6CLK Class
7CO: BMW
8M3 (DONE)
9M5
10M6 (DONE)
11X5
12CO: Jaguar
13F type (DONE)
14X type
London Vigs
 
Upvote 0

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Incorrect code
 
Last edited:
Upvote 0
Maybe

Code: 
Sub donecode()
Dim wsl As Worksheet
Dim wsf As Worksheet
Dim lrl As Long
Dim lrf As Long
Dim lrx As Long
Dim rng As Range
Dim srng As Range
Dim mysearch As Range
Dim pos As Long
Set wsl = Sheets("London Vigs")
Set wsf = Sheets("File")
lrl = wsl.Cells(Rows.Count, 1).End(xlUp).Row 'last row of london vigs sheet
wsl.Range("A1").Copy wsf.Range("A1")
lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row 'last row of file sheet
Set rng = wsl.Range("A2:A" & lrl)
wsl.Range("A1").Copy wsf.Range("A1")
lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In rng
    lrx = cell.End(xlDown).Row
    lrc = cell.Row
    Set srng = cell.Resize(lrx - lrc, 1)
    Set mysearch = srng.Find("(DONE)")
       
    If UCase(Left(cell, 3)) = "CO:" And Not mysearch Is Nothing Then
            cell.Copy wsf.Cells(lrf + 1, 1)
    End If
    lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row
    
    pos = InStr(UCase(cell), "(DONE)")
    If pos > 0 Then
        cell.Cut wsf.Cells(lrf + 1, 1)
    End If
    
    lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row
Next cell
'delete now empty rows on Longdon Vigs sheet
For x = lrl To 2 Step -1
    If Range("A" & x) = "" Then Rows(x).Delete
Next x
End Sub
 
Upvote 0
How about
Code: 
Sub CopyWithSubHeader()
   
   Dim Cnt As Long
   Dim Ar As Areas
   
   With Sheets("London Vigs")
      With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         .Replace "Co:", "=N/A", xlPart, , False, , False, False
         Set Ar = .SpecialCells(xlConstants).Areas
         .Replace "=N/A", "Co:", xlPart, , False, , False, False
         For Cnt = Ar.Count To 1 Step -1
            With Ar(Cnt).Offset(-1).Resize(Ar(Cnt).Count + 1, 2)
               .AutoFilter 1, "*done*"
               On Error Resume Next
               .SpecialCells(xlVisible).EntireRow.Copy _
                  Sheets("File").Range("A" & Rows.Count).End(xlUp).Offset(1)
               On Error GoTo 0
               .AutoFilter
            End With
         Next Cnt
      End With
   End With
End Sub
 
Upvote 0
Scott T said:
Maybe

Code: 
Sub donecode()
Dim wsl As Worksheet
Dim wsf As Worksheet
Dim lrl As Long
Dim lrf As Long
Dim lrx As Long
Dim rng As Range
Dim srng As Range
Dim mysearch As Range
Dim pos As Long
Set wsl = Sheets("London Vigs")
Set wsf = Sheets("File")
lrl = wsl.Cells(Rows.Count, 1).End(xlUp).Row 'last row of london vigs sheet
wsl.Range("A1").Copy wsf.Range("A1")
lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row 'last row of file sheet
Set rng = wsl.Range("A2:A" & lrl)
wsl.Range("A1").Copy wsf.Range("A1")
lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In rng
    lrx = cell.End(xlDown).Row
    lrc = cell.Row
    Set srng = cell.Resize(lrx - lrc, 1)
    Set mysearch = srng.Find("(DONE)")
       
    If UCase(Left(cell, 3)) = "CO:" And Not mysearch Is Nothing Then
            cell.Copy wsf.Cells(lrf + 1, 1)
    End If
    lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row
    
    pos = InStr(UCase(cell), "(DONE)")
    If pos > 0 Then
        cell.Cut wsf.Cells(lrf + 1, 1)
    End If
    
    lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row
Next cell
'delete now empty rows on Longdon Vigs sheet
For x = lrl To 2 Step -1
    If Range("A" & x) = "" Then Rows(x).Delete
Next x
End Sub
Click to expand...

thanks Scott, the above code works but as I keep adding the wording (DONE) and click on the macro button, all my sub-headings get copied over again so the more i use the button, the more sub heading re-appear.
Can these sub headings only be copied over once? then only the data belonging to each sub header gets moved from tab 1 to tab2?

cheers for your help!
 
Upvote 0
Try

Code: 
Sub donecode()
Dim wsl As Worksheet
Dim wsf As Worksheet
Dim lrl As Long
Dim lrf As Long
Dim lrx As Long
Dim rng As Range
Dim srng As Range
Dim mysearch As Range
Dim pos As Long
Dim mfound As Range
Set wsl = Sheets("London Vigs")
Set wsf = Sheets("File")
lrl = wsl.Cells(Rows.Count, 1).End(xlUp).Row 'last row of london vigs sheet
wsl.Range("A1").Copy wsf.Range("A1")
lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row 'last row of file sheet
Set rng = wsl.Range("A2:A" & lrl)
wsl.Range("A1").Copy wsf.Range("A1")
Application.ScreenUpdating = False
lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In rng
    lrx = cell.End(xlDown).Row
    lrc = cell.Row
    Set mfound = wsf.Range("A2:A" & lrf).Find(cell)
    If mfound Is Nothing And UCase(Left(cell, 3)) = "CO:" Then
        Set srng = cell.Resize(lrx - lrc, 1)
        Set mysearch = srng.Find("(DONE)")
        If Not mysearch Is Nothing Then
            cell.Copy wsf.Cells(lrf + 1, 1)
        End If
        lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row
        subhead = cell
    Else
        'subheader exists on file sheet
        If UCase(Left(cell, 3)) = "CO:" Then subhead = cell
    End If
    
    
    pos = InStr(UCase(cell), "(DONE)")
    If pos > 0 Then
        Set mfound = wsf.Range("A2:A" & lrf).Find(subhead)
        newrow = mfound.Row + 1
        wsf.Rows(newrow).Insert
        cell.Cut wsf.Cells(newrow, 1)
    End If
    
    lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row
Next cell
'delete now empty rows on Longdon Vigs sheet
For x = lrl To 2 Step -1
    If wsl.Range("A" & x) = "" Then wsl.Rows(x).Delete
Next x
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Scott T said:
Try

Code: 
Sub donecode()
Dim wsl As Worksheet
Dim wsf As Worksheet
Dim lrl As Long
Dim lrf As Long
Dim lrx As Long
Dim rng As Range
Dim srng As Range
Dim mysearch As Range
Dim pos As Long
Dim mfound As Range
Set wsl = Sheets("London Vigs")
Set wsf = Sheets("File")
lrl = wsl.Cells(Rows.Count, 1).End(xlUp).Row 'last row of london vigs sheet
wsl.Range("A1").Copy wsf.Range("A1")
lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row 'last row of file sheet
Set rng = wsl.Range("A2:A" & lrl)
wsl.Range("A1").Copy wsf.Range("A1")
Application.ScreenUpdating = False
lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In rng
    lrx = cell.End(xlDown).Row
    lrc = cell.Row
    Set mfound = wsf.Range("A2:A" & lrf).Find(cell)
    If mfound Is Nothing And UCase(Left(cell, 3)) = "CO:" Then
        Set srng = cell.Resize(lrx - lrc, 1)
        Set mysearch = srng.Find("(DONE)")
        If Not mysearch Is Nothing Then
            cell.Copy wsf.Cells(lrf + 1, 1)
        End If
        lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row
        subhead = cell
    Else
        'subheader exists on file sheet
        If UCase(Left(cell, 3)) = "CO:" Then subhead = cell
    End If
    
    
    pos = InStr(UCase(cell), "(DONE)")
    If pos > 0 Then
        Set mfound = wsf.Range("A2:A" & lrf).Find(subhead)
        newrow = mfound.Row + 1
        wsf.Rows(newrow).Insert
        cell.Cut wsf.Cells(newrow, 1)
    End If
    
    lrf = wsf.Cells(Rows.Count, 1).End(xlUp).Row
Next cell
'delete now empty rows on Longdon Vigs sheet
For x = lrl To 2 Step -1
    If wsl.Range("A" & x) = "" Then wsl.Rows(x).Delete
Next x
Application.ScreenUpdating = True
End Sub
Click to expand...

AMAZING!!!!
Thanks buddy. it DOES WORK SUPER WELL
 
Upvote 0
Hi mate, one more question.

right now it does a super job. It transfers data (with wording DONE) from one tab to another, with the sub headings. I LOVE IT.
Can you show me which bit I have to tweak in the code in order to get in the file tab, data from column A to column F copied over? This include data and sub-headings. the Header is fine and can stay as is with only column A.
So far, I have only data from column A that gets copied over to file tab. Need A to F.

I have been playing with your code but I can't work out which bit I need to tweak to make that happen.

let me know if unclear.

cheers buddy!
 
Upvote 0
So when column A has (DONE) the row A though F should be moved to file? Could you post an example
 
Upvote 0
you're absolutely correct.


CFT/GTREDGTY/030 (DONE) - 11/20 - 11/27 - 12/05 - 12/08 - email: brian.xxxx@fghju.com

let's pretend the above data is sitting across different column... from A to F
if the word (DONE) appear in column A, then ALL above data should be moved to the FILE tab.

thanks dude.
Take care,
Mike
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question
Searching multiple occurence of same keyword from text file and saving its output in different Excel worksheets
Replies
5
Views
67
myall_blues
myall_blues
P
  • Question
Need VBA to automatically copy paste rows based on dates of current month.
2
Replies
11
Views
311
pk970
P
Kaz09
  • Question
Copy rows of data from multiple worksheets to based on column equalling YES
Replies
0
Views
129
Kaz09
Kaz09
T
  • Solved
Making the contents of the active cell the search term, and search using that term, copy paste row, next
Replies
2
Views
197
Travis Kunnen
T
B
  • Solved
VBA to copy and paste based on multiple conditions
Replies
7
Views
1K
Beginner001
B

Forum statistics

Threads
1,215,560
Messages
6,125,527
Members
449,236
Latest member
Afua

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