Finding text, copying row & pasting into separate sheet

PE New User

New Member
Joined
Aug 4, 2014
Messages
21
Hi,

I am pretty sure that this should be a relatively straight forward macro, but I can't seem to work it out. I am trying to find data in a spreadsheet (data always in column H), once found copy the entire row and paste the row into a different tab.

There are multiple rows within the original (Data Sheet) tab that will contain the specific text (Natural Gas) so I want the macro to loop through and copy all rows with Natural Gas in column H to the new tab:

Original Sheet
Client NameSite Name........................Product
ABC Intl Ltd1 ABC StreetElectricity HH
ABC Intl Ltd2 ABC StreetNatural Gas
ABC Intl Ltd3 ABC StreetElectricity NHH
ABC Intl Ltd3 ABC StreetNatural Gas
ABC Intl Ltd4 ABC StreetNatural Gas
ABC Intl Ltd7 ABC StreetElectricity HH

<tbody>
</tbody>

New Sheet
Client NameSite Name........................Product
ABC Intl Ltd2 ABC StreetNatural Gas
ABC Intl Ltd3 ABC StreetNatural Gas
ABC Intl Ltd4 ABC StreetNatural Gas

<tbody>
</tbody>

I have been playing with script and have come up with the following so far, but it only really works to the point of EntireRow.Copy - I can't quite work out how to get the select tab "Gas" and paste the row in the first available row before the loop:

Code:
Sub GasExtract()


Dim rngH As Range
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


    Worksheets("DATA SHEET").Activate
    
    Range("H2").Select
    'Range(Selection, Selection.End(xlDown)).Select
 
 x = 2
 Do Until Range("H" & x) = ""
    If Range("H" & x).Value = "Natural Gas" Then Range("H" & x).EntireRow.Copy
        Sheets("Gas").Select
    ' Go to last cell and extend down
        Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
    ' Copy formula from cell above
        Rows(Selection.Row - 1).Copy
        Rows(Selection.Row).PasteSpecial


x = x + 1
Loop
        
    With Application
       .ScreenUpdating = True
       .EnableEvents = True
    End With
     
End Sub

Would appreciate any assistance that can be provided.
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".

iliauk

Board Regular
Joined
Jun 3, 2014
Messages
163
I think this:

Code:
Sub CopyRows()
Application.ScreenUpdating = False
Dim lrsource As Long
Dim lrdest As Long
Dim i As Long
lrsource = Sheets("DATA SHEET").Cells(Rows.Count, "H").End(xlUp).Row
lrdest = Sheets("Gas").Cells(Rows.Count, "H").End(xlUp).Row


For i = 2 To lrsource
    If Range("H" & i).Value = "Natural Gas" Then
        Rows(i).copy Destination:=Sheets("Gas").Range("A" & lrdest)
        lrdest = lrdest + 1
    End If
Next i
Application.ScreenUpdating = True
End Sub
 
Upvote 0

NeonRedSharpie

Well-known Member
Joined
Jul 14, 2014
Messages
1,678
Code:
Sub GasExtract()

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim dws As Worksheet
    Dim gas As Worksheet
    
    Dim findVal As String
    ' The value to copy on in **all caps** (you'll see why later)
    findVal = "NATURAL GAS"
    
    ' Name your sheets
    Set dws = ThisWorkbook.Sheets("DATA SHEET")
    Set gas = ThisWorkbook.Sheets("Gas")
    
    Dim maxRow As Long
    Dim nextRow As Long
    
    ' find max row for loop and dim next row for copying
    maxRow = dws.Cells(Rows.Count, "H").End(xlUp).Row
    nextRow = 2
    
    
    ' Add the header
    gas.Rows(1).EntireRow.Value = dws.Rows(1).EntireRow.Value
    
    
    'Loop through the rows
    For x = 2 To maxRow
        'Eliminate enter errors by using uppercase
        If UCase(dws.Cells(x, 8)) = findVal Then
            gas.Cells(nextRow, 1).EntireRow.Value = dws.Cells(x, 1).EntireRow.Value
            nextRow = nextRow + 1
        End If
    Next x
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    




End Sub

Commented out for your learning ability.
 
Upvote 0

hiker95

Well-known Member
Joined
Apr 8, 2009
Messages
17,649
PE New User,

Sample worksheets:


Excel 2007
ABCDEFGH
1Client NameSite Name........................Product
2ABC Intl Ltd1 ABC StreetElectricity HH
3ABC Intl Ltd2 ABC StreetNatural Gas
4ABC Intl Ltd3 ABC StreetElectricity NHH
5ABC Intl Ltd3 ABC StreetNatural Gas
6ABC Intl Ltd4 ABC StreetNatural Gas
7ABC Intl Ltd7 ABC StreetElectricity HH
8
DATA SHEET



Excel 2007
ABCDEFGH
1Client NameSite Name........................Product
2
3
4
5
Gas


After the macro (using two array in memory) in worksheet Gas:


Excel 2007
ABCDEFGH
1Client NameSite Name........................Product
2ABC Intl Ltd2 ABC StreetNatural Gas
3ABC Intl Ltd3 ABC StreetNatural Gas
4ABC Intl Ltd4 ABC StreetNatural Gas
5
Gas


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code:
Sub GetNaturalGas()
' hiker95, 09/11/2014, ME804813
Dim wd As Worksheet, wg As Worksheet
Dim a As Variant, o As Variant
Dim i As Long, j As Long, c As Long
Dim lr As Long, n As Long
Set wd = Sheets("DATA SHEET")
With wd
  n = Application.CountIf(.Columns(8), "Natural Gas")
  If n = 0 Then
    MsgBox "Sheet " & wd & " column H 'Product' does not contain 'Natural Gas' - macro terminated!"
    Exit Sub
  End If
  Application.ScreenUpdating = False
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  a = .Range("A1:H" & lr).Value
  ReDim o(1 To n + 1, 1 To 8)
End With
j = j + 1
For c = 1 To 8
  o(j, c) = a(1, c)
Next c
For i = 2 To lr
  If a(i, 8) = "Natural Gas" Then
    j = j + 1
    For c = 1 To 8
      o(j, c) = a(i, c)
    Next c
  End If
Next i
If Not Evaluate("ISREF(Gas!A1)") Then Worksheets.Add(After:=wd).Name = "Gas"
Set wg = Sheets("Gas")
With wg
  .UsedRange.ClearContents
  .Cells(1, 1).Resize(n + 1, 8).Value = o
  .UsedRange.Columns.AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the GetNaturalGas macro.
 
Upvote 0

Forum statistics

Threads
1,195,600
Messages
6,010,650
Members
441,558
Latest member
lambierules

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
Top