VBA Help with last row and paste special

[VBAIsNotMyStrongSuit]

Hey all,

Not sure if this is something you all can assist on, I've been searching through the site for a bit during this project and found great help. I've been tasked with automating some reporting at work that involves pulling data from emails, we get a blanket email and I need to extract certain parts that are different in every email. I have that done and am using a horribly complex system of formulas in excel to parse the data needed into the rows they need to be entered into on the spreadsheet (Columns A:AK, but only columns D, J, Z, AC, AI, AJ and AK are needed, the rest are used to extract that specific data). I've tried copying just those columns to a separate sheet, but my issue persists.

The issue I'm having is since all columns B:AK have formulas in them, they aren't seen as blanks, so it copies cells with no data from Sheet 1 to Sheet 3. which makes it impossible to just add onto the bottom when another round of emails come in. I also need to ensure I'm only taking values, not formulas from sheet 1 as the reporting has conditional formatting in place. This is the code I'm working with now:

Sub KindOfWorksNoLastRow()
    Dim rng1 As Range
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet3")
    On Error Resume Next
    Set rng1 = ws1.Range(ws1.[A2], ws1.Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlConstants)
    On Error GoTo 0
    If rng1 Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set rng2 = ws2.[A8:a100]
    rng1.Copy
    rng2.PasteSpecial xlPasteValues
    'Store #
    rng1.Offset(0, 3).Copy
    rng2.Offset(0, 0).PasteSpecial xlPasteValues
    'Issue ID
    rng1.Offset(0, 6).Copy
    rng2.Offset(0, 2).PasteSpecial xlPasteValues
    'Display
    rng1.Offset(0, 9).Copy
    rng2.Offset(0, 3).PasteSpecial xlPasteValues
    'Critical
    rng1.Offset(0, 12).Copy
    rng2.Offset(0, 4).PasteSpecial xlPasteValues
    'Escalator
    rng1.Offset(0, 25).Copy
    rng2.Offset(0, 5).PasteSpecial xlPasteValues
    'Date
    rng1.Offset(0, 28).Copy
    rng2.Offset(0, 6).PasteSpecial xlPasteValues
    'Comments
    rng1.Offset(0, 34).Copy
    rng2.Offset(0, 7).PasteSpecial xlPasteValues
    'L3
    rng1.Offset(0, 35).Copy
    rng2.Offset(0, 8).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

I've also tried using:
Sub PasteSpecial_ValuesOnly()
  Worksheets("Sheet1").Range("D2:D100").Copy 'Store #
  Worksheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, skipblanks:=True
  Worksheets("Sheet1").Range("G2:G100").Copy 'Issue #
  Worksheets("Sheet3").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, skipblanks:=True
  Worksheets("Sheet1").Range("J2:J100").Copy 'Plano
  Worksheets("Sheet3").Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, skipblanks:=True
  Worksheets("Sheet1").Range("M2:M100").Copy 'Critical?
  Worksheets("Sheet3").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, skipblanks:=True
  Worksheets("Sheet1").Range("Z2:Z100").Copy 'Contact
  Worksheets("Sheet3").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, skipblanks:=True
  Worksheets("Sheet1").Range("AC2:AC100").Copy 'Date Received
  Worksheets("Sheet3").Range("I" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, skipblanks:=True
  Worksheets("Sheet1").Range("AI2:AI100").Copy 'Comments
  Worksheets("Sheet3").Range("G" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, skipblanks:=True
End Sub

 

[JLGWhiz]

if you no longer need the formulas in the sheet after the data has been transferred, you could run something like this to get rid of the formulas and empty rows.

Sub t()
Dim lr As Long, i As Long
With ActiveSheet.UsedRange
    .Value = .Value
    lr = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
    For i = lr To 2 Step -1
        If Application.CountA(.Rows(i)) = 0 Then
            .Rows(i).Delete
        End If
    Next
End With
End Sub

Be sure you test this on a copy, before appying it to your original file.