Extracting Certain Header Columns & Paste Special

[NeoSez]

I am trying to extract certain columns from a downloaded spreadsheet that contains too much information. I only want certain columns and another column has concatenated data.

How to clear all contents to last used row, but but leave formatting and formulas intact?
How Paste Special all the concatenated data? Paste Special does not appear to be working in my Macro. Throws an endless amount of errors that I have to kill Excel to get out of it.
Sorry if I am not explaining properly. I am new to this. Thank you for your help.

Option Explicit

Function GetHeadersDict() As Scripting.Dictionary
' We must activate the Microsoft Scripting Runtime from Tools --References

Dim result As Scripting.Dictionary

    Set result = New Scripting.Dictionary

    With result
     
        .Add "Tracking #", False
        .Add "Call Date", False
        .Add "Status", False
        .Add "Address", False
        .Add "Problem", False
        .Add "Box", False
        .Add "State", False


        
    End With

    Set GetHeadersDict = result
    
End Function

Function FindHeaderRange(ByVal ws As Worksheet, ByVal header As String) As Range

    Set FindHeaderRange = ws.Cells.Find(header, , , xlWhole)
    
End Function

Sub clearDataSheet2()

Sheets("Extract").Range("A2:H30").CurrentRegion.Offset(1).ClearContents 'How to clear all contents to last used row, but but leave formatting and formulas intact?'

End Sub


Sub copyColumnData()


On Error GoTo ErrorMessage
    
Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Report")
    Set ws2 = ThisWorkbook.Sheets("Extract")
    
    clearDataSheet2

Dim numRowsToCopy As Long

    numRowsToCopy = ws1.Cells(RowIndex:=Rows.Count, ColumnIndex:=1).End(xlUp).Row - 1
    'MsgBox "The no of rows to copy is " & numRowsToCopy
    
Dim destRowOffset As Long
 
    destRowOffset = ws2.Cells(RowIndex:=Rows.Count, ColumnIndex:=1).End(xlUp).Row
    'MsgBox "The next Blank row is " & destRowOffset

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    
Dim dictKey As Variant
Dim header As String
Dim numColumnsToCopy As Long
Dim Report As Range
Dim dest As Range

Dim headersDict As Scripting.Dictionary

    Set headersDict = GetHeadersDict()

    For Each dictKey In headersDict
        header = dictKey
        If headersDict.Item(header) = False Then
            Set Report = FindHeaderRange(ws1, header)
            If Not (Report Is Nothing) Then
                Set dest = FindHeaderRange(ws2, header)
                If Not (dest Is Nothing) Then
                    headersDict.Item(header) = True
                    ' Look at successive headers to see if they match
                    ' If so, copy these columns altogether to make the macro faster
                    For numColumnsToCopy = 1 To headersDict.Count
                        'MsgBox numColumnsToCopy
                        If Report.Offset(ColumnOffset:=numColumnsToCopy).Value = dest.Offset(ColumnOffset:=numColumnsToCopy).Value Then
                            headersDict.Item(Report.Offset(ColumnOffset:=numColumnsToCopy).Value) = True
                            
                        Else
                            Exit For
                        End If
                        
                    Next numColumnsToCopy

                    Report.Offset(RowOffset:=1).Resize(RowSize:=numRowsToCopy, ColumnSize:=numColumnsToCopy).Copy _
                        dest.Offset(RowOffset:=destRowOffset)
                End If
            End If
        End If
    Next dictKey

Dim msg As String

    For Each dictKey In headersDict
        header = dictKey
        If headersDict.Item(header) = False Then
            msg = msg & vbNewLine & header
        End If
    Next dictKey

ExitSub:
Sheets("Report").Range("A2:H30").Copy
Sheets("Extract").PasteSpecial Paste:=xlPasteValues 'Paste Special does not appear to be working'
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    If msg <> "" Then
        MsgBox "The following headers were not copied:" & vbNewLine & msg
    End If
Exit Sub

ErrorMessage:
    MsgBox "An error has occurred: " & Err.Description
    Resume ExitSub

End Sub

Private Sub CommandButton1_Click()

End Sub

 

[Norie]

Which columns do you want to extract?

Is the image you posted before or after?

 

[NeoSez]

Hi Norie. The image is the after. So those are the columns extracted.
The image below is the Before.