VBA Code to Loop through Data and Copy if it does not equal one of the following

[OilEconomist]

Thanks in advance for any suggestions as I will post feedback for them.

I am trying to loop through Column A and when the cell does not equal one of the listed items, I would like to copy a section of that data. Here is my code thus far.

Sub Macro(1)
 
'Dimensioning
          Dim LastRow As Long
          Dim LRPHDW As Long
          Dim StartRow As Long
          Dim i As Long
 
'Find the Last Row of all the data
              LastRow = Cells.Find(What:="*", after:=Range("A1"), LookAt:=xlPart, _
              LookIn:=xlFormulas, SearchOrder:=xlByRows, _
              SearchDirection:=xlPrevious, MatchCase:=False).Row
 
'Find the Last Row of this section of data which will be the same length for all _
sections of data that will be copied
              LRPHDW = Range("A5").End(xlDown).Offset(1).Row
              LRPHDW = LRPHDW - 2
 
'Loop through Column A to copy the appropriate sections
 
              For i = 1 to LastRow
 
               'I want to loop through column A starting with cell "A1" through "A"&LastRow._
               Once the cell in Column A does not equal one of the following, I would like _
               copy the data two rows below it going from column B through Column P through _
               LRPHDW _
                          Blank cell _
                          Left 4 characters will be equal to "Date" _
                           "Rem." _
                          Have a date in it with the format "m/d/yyyy" _
             
              'Copy the data
 
                         'Copy tab "SheetA" after tab "SheetB" and paste the copied data _
                         starting in cell B11
 
End Sub

 

[JLGWhiz]

two thing are not clear.
1. Is your data separated by blank rows (including no formulas in the row)
2. Do you want to add a sheet to paste to, or is there a sheet C that currently exists that you want to paste to?

 

[OilEconomist]

Thanks JLGWhiz!

Responses are as follows:

Question 1. Is your data separated by blank rows (including no formulas in the row)
Response: Not entirely, but column A which I am looping through has blank cells between each set of data.

Question 2. Do you want to add a sheet to paste to, or is there a sheet C that currently exists that you want to paste to?
Response: There is an existing sheet "SheetA" which I would like to make a copy of and place it after "SheetB." We can call that "SheetC" and then paste the copied date into it.

Hope this clarifies and thanks so much for your help.

 

[JLGWhiz]

If your data is separated by blank rows and there is a SheetC in existing, then this code might do what you want.

Sub t()
Dim rng As Range
With Sheets("SheetA").UsedRange
    For Each rng In .SpecialCells(xlCellTypeConstants).Areas
        If Sheets("SheetC").Range("B11") = "" Then
            rng.Offset(, 1).Copy Sheets("SheetC").Range("B11")
        Else
            rng.Offset(, 1).Copy Sheets("SheetC").Cells(Rows.Count, 2).End(xlUp)(2)
        End If
    Next
End With
End Sub

 

[JLGWhiz]

I am confused about where you are copying from and what you want ot paste to. To save time let's get the sheet situation cleared up.

1. What is the sheet name you copy from?
2. If you are copying from sheet A, then why not just copy the sheet and delete what you do not want?
3. If you are not copying from sheet A and you want to make a copy of it to paste the copied data to, then do you want to delete any existing data from the copy, overwrite existing data or append at the bottom of existing data?

 

[JLGWhiz]

Guesing at the answers. Here is what I came up with.

Sub t2()
Dim c As Range, sh As Worksheet
Set sh = ActiveSheet
Sheets("SheetA").Copy After:=Sheets("SheetB")
ActiveSheet.Name = "SheetC"
ActiveSheet.UsedRange.Offset(4).ClearContents
    With sh
        For Each c In .Range("A5", .Cells(Rows.Count, 1).End(xlUp))
            If c <> "" And c <> "Date" And c <> "Rem." And Not IsDate(c) Then
                If Sheets("SheetC").Range("B11") = "" Then
                    c.Offset(, 1).Resize(, 15).Copy Sheets("SheetC").Range("B11")
                Else
                    c.Offset(, 1).Resize(, 15).Copy Sheets("SheetC").Cells(Rows.Count, 2).End(xlUp)(2)
                End If
            End If
        Next
    End With
End Sub

 

[OilEconomist]

JLGWhiz Thanks so much for your hard work!

I tested it and it did not work most probably because of my lack of clarity in my request. Now the good news is I think I can use this to modify for my request. I will piece something together and let you know the outcome.