Extracting Certain Header Columns & Paste Special

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
128
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
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.

VBA Code:
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
 

Attachments

  • sample1.JPG
    sample1.JPG
    188 KB · Views: 3

Some videos you may like

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,047
Office Version
  1. 365
Platform
  1. Windows
Which columns do you want to extract?

Is the image you posted before or after?
 

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
128
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Hi Norie. The image is the after. So those are the columns extracted.
The image below is the Before.
 

Attachments

  • before.JPG
    before.JPG
    55.4 KB · Views: 2

Watch MrExcel Video

Forum statistics

Threads
1,118,134
Messages
5,570,348
Members
412,320
Latest member
sixnine0312
Top