VBA: Copy Columns to New Workbook

[NeoSez]

Would appreciate some help with a script to copy data from one workbook and paste special to another another workbook without the formulas.
Currently, I have been using a script using the column header name, but sometimes the column name is differently named in French. I would like to just use "copy from column "A" starting at row 4 to workbook2 column "B" starting at row 2. Is that possible? Or must I used the column header name?

 

[Alex Blakenburg]

If you have working code and that is the only change, post the code you are currently using.

 

[NeoSez]

Hi Alex,
I was given this VBA code from someone in here (Thank you!) and the sheet I am working with has header names with instructions and formulas so too long to name.
I want to copy only certain columns to another sheet, such as this example:
from SHEET1 COL "A4" to SHEET2 COL "C2"
SHEET1 COL "B4" to SHEET2 COL "D2"

The VBA code below has the column headers named.
Can you help me modify this?
Thank you.

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:Z30").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:Z30").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

 

[Alex Blakenburg]

That code is very much aimed at using Column Headers and even has a message box for columns not copied across.
Are you sure you want it to run based on column position (ie A to C, B to D etc) ?
If that is the case we may as well rewrite it from scratch.
Are you only copying across values without formulas or formatting ?

 

[NeoSez]

That code is very much aimed at using Column Headers and even has a message box for columns not copied across.
Are you sure you want it to run based on column position (ie A to C, B to D etc) ?
If that is the case we may as well rewrite it from scratch.
Are you only copying across values without formulas or formatting ?

That's correct Alex. I would like to copy across the data only, no formulas or formatting, based on column positions. That way, if the header is misspelled, it doesn't matter.
The sheet I am copying to has some formulas in a few columns though.

 

[Alex Blakenburg]

The advantage of the original method was that if the columns moved around it would still work as long as the heading names stay the same.
The below should do what you asked for.

You are saying some of the columns on your Extract sheet have formulas. You need to think about what will happen with those columns if the data your are copying in is longer or shorter than the destination number of rows.

Sub copyColumnDataByPosition()
    
    Dim wsRpt As Worksheet, wsDest As Worksheet
    Dim rptFirsRow As Long, rptLastRow As Long
    Dim destFirstRow As Long, destLastRow As Long
    Dim colToCopy As Variant, colDest As Variant
    Dim i As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wsRpt = ThisWorkbook.Sheets("Report")
    Set wsDest = ThisWorkbook.Sheets("Extract")
    
    rptFirsRow = 4
    destFirstRow = 2
    
    colToCopy = Array("A", "B")                ' List of columns to copy
    colDest = Array("C", "D")                   ' Matching list of columns to paste to
    
    With wsRpt
        rptLastRow = .Range("A" & Rows.Count).End(xlUp).Row
    End With
    
    For i = LBound(colToCopy) To UBound(colToCopy)
        With wsRpt
            With .Range(.Cells(rptFirsRow, colToCopy(i)), .Cells(rptLastRow, colToCopy(i)))
                wsDest.Cells(destFirstRow, colDest(i)).Resize(.Rows.Count).Value = .Value
            End With
        End With
    Next i

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

 

[NeoSez]

The advantage of the original method was that if the columns moved around it would still work as long as the heading names stay the same.
The below should do what you asked for.

You are saying some of the columns on your Extract sheet have formulas. You need to think about what will happen with those columns if the data your are copying in is longer or shorter than the destination number of rows.

Sub copyColumnDataByPosition()
   
    Dim wsRpt As Worksheet, wsDest As Worksheet
    Dim rptFirsRow As Long, rptLastRow As Long
    Dim destFirstRow As Long, destLastRow As Long
    Dim colToCopy As Variant, colDest As Variant
    Dim i As Long
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set wsRpt = ThisWorkbook.Sheets("Report")
    Set wsDest = ThisWorkbook.Sheets("Extract")
   
    rptFirsRow = 4
    destFirstRow = 2
   
    colToCopy = Array("A", "B")                ' List of columns to copy
    colDest = Array("C", "D")                   ' Matching list of columns to paste to
   
    With wsRpt
        rptLastRow = .Range("A" & Rows.Count).End(xlUp).Row
    End With
   
    For i = LBound(colToCopy) To UBound(colToCopy)
        With wsRpt
            With .Range(.Cells(rptFirsRow, colToCopy(i)), .Cells(rptLastRow, colToCopy(i)))
                wsDest.Cells(destFirstRow, colDest(i)).Resize(.Rows.Count).Value = .Value
            End With
        End With
    Next i

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

This is brilliant Alex. Thank you so much. It worked really well. The columns with the formulas have not been overridden with any data. It is just a sum of the data copied over. Thank you for bringing this to my attention.
Also, if I use a main Workbook that contains all the VBA scripts, can I just add a button that will copy workbook to workbook? I modified the code below to a named workbook to workbook and the destination sheets named. Did I do this correctly?

Sub copyColumnDataByPosition()
    
    Dim wsRpt As sourceWorkbook, wsDest As destWorkbook
    Dim rptFirsRow As Long, rptLastRow As Long
    Dim sourceSheet As Worksheet, targetSheet As tgtWorksheet
    Dim destFirstRow As Long, destLastRow As Long
    Dim colToCopy As Variant, colDest As Variant
    Dim i As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wsRpt = sourceWorkbook ("SOURCE.xlsm")
    Set sourceSheet = Worksheet (sheet1)
    Set wsDest = destWorkbook("TARGET.xlsm")
    Set targetSheet = tgtWorksheet (tgtsheet)
    rptFirsRow = 4
    destFirstRow = 7
    
    colToCopy = Array("J", "S", "T", "X", "Z")                ' List of columns to copy
    colDest = Array("Q", "C", "V", "W", "R")                   ' Matching list of columns to paste to
    
    With wsRpt
        rptLastRow = .Range("A" & Rows.Count).End(xlUp).Row
    End With
    
    For i = LBound(colToCopy) To UBound(colToCopy)
        With wsRpt
            With .Range(.Cells(rptFirsRow, colToCopy(i)), .Cells(rptLastRow, colToCopy(i)))
                wsDest.Cells(destFirstRow, colDest(i)).Resize(.Rows.Count).Value = .Value
            End With
        End With
    Next i

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

 

[Alex Blakenburg]

I'm afraid not.
You are mixing sheets and workbooks.
You can use a different naming convention but you will often see ws or wb which indicates the variable is intended to be a worksheet or workbook.
If you use them differently then you are going to confuse most people reading the code.

You need to define the workbooks first and then use that to define your worksheets, the range references should then be an extension of the sheet references.

Get rid of this

    Dim sourceSheet As Worksheet, targetSheet As tgtWorksheet

    Set wsRpt = sourceWorkbook ("SOURCE.xlsm")
    Set sourceSheet = Worksheet (sheet1)
    Set wsDest = destWorkbook("TARGET.xlsm")
    Set targetSheet = tgtWorksheet (tgtsheet)

Replace it with this:
Change the sheet names to your sheet names.
That format needs the 2 workbooks to be open.

    Dim sourceWorkbook As Workbook, destWorkbook As Workbook
    
    Set sourceWorkbook = Workbooks("SOURCE.xlsm")
    Set destWorkbook = Workbooks("TARGET.xlsm")
    
    Set wsRpt = sourceWorkbook.Worksheets("Report")
    Set wsDest = destWorkbook.Worksheets("Extract")

 

[NeoSez]

I'm afraid not.
You are mixing sheets and workbooks.
You can use a different naming convention but you will often see ws or wb which indicates the variable is intended to be a worksheet or workbook.
If you use them differently then you are going to confuse most people reading the code.

You need to define the workbooks first and then use that to define your worksheets, the range references should then be an extension of the sheet references.

Get rid of this

    Dim sourceSheet As Worksheet, targetSheet As tgtWorksheet

    Set wsRpt = sourceWorkbook ("SOURCE.xlsm")
    Set sourceSheet = Worksheet (sheet1)
    Set wsDest = destWorkbook("TARGET.xlsm")
    Set targetSheet = tgtWorksheet (tgtsheet)

Replace it with this:
Change the sheet names to your sheet names.
That format needs the 2 workbooks to be open.

    Dim sourceWorkbook As Workbook, destWorkbook As Workbook
   
    Set sourceWorkbook = Workbooks("SOURCE.xlsm")
    Set destWorkbook = Workbooks("TARGET.xlsm")
   
    Set wsRpt = sourceWorkbook.Worksheets("Report")
    Set wsDest = destWorkbook.Worksheets("Extract")

Alex, thank you so much for your patience and guidance as well as making it easy for me to understand you scripts so I can continue learning. I really appreciate you sharing your knowledge.

 

[Alex Blakenburg]

You're welcome. Happy to help.