Finding text, copying row & pasting into separate sheet

[PE New User]

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 Name	Site Name	.....	....	.....	.....	.....	Product
ABC Intl Ltd	1 ABC Street						Electricity HH
ABC Intl Ltd	2 ABC Street						Natural Gas
ABC Intl Ltd	3 ABC Street						Electricity NHH
ABC Intl Ltd	3 ABC Street						Natural Gas
ABC Intl Ltd	4 ABC Street						Natural Gas
ABC Intl Ltd	7 ABC Street						Electricity HH

<tbody>
</tbody>

New Sheet

Client Name	Site Name	.....	....	.....	.....	.....	Product
ABC Intl Ltd	2 ABC Street						Natural Gas
ABC Intl Ltd	3 ABC Street						Natural Gas
ABC Intl Ltd	4 ABC Street						Natural 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:

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.

 

[iliauk]

I think this:

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

 

[NeonRedSharpie]

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.

 

[hiker95]

PE New User,

Sample worksheets:

Excel 2007
	A	B	C	D	E	F	G	H
1	Client Name	Site Name	.....	....	.....	.....	.....	Product
2	ABC Intl Ltd	1 ABC Street						Electricity HH
3	ABC Intl Ltd	2 ABC Street						Natural Gas
4	ABC Intl Ltd	3 ABC Street						Electricity NHH
5	ABC Intl Ltd	3 ABC Street						Natural Gas
6	ABC Intl Ltd	4 ABC Street						Natural Gas
7	ABC Intl Ltd	7 ABC Street						Electricity HH
8
DATA SHEET

Excel 2007
	A	B	C	D	E	F	G	H
1	Client Name	Site Name	.....	....	.....	.....	.....	Product
2
3
4
5
Gas

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

Excel 2007
	A	B	C	D	E	F	G	H
1	Client Name	Site Name	.....	....	.....	.....	.....	Product
2	ABC Intl Ltd	2 ABC Street						Natural Gas
3	ABC Intl Ltd	3 ABC Street						Natural Gas
4	ABC Intl Ltd	4 ABC Street						Natural 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.

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.