CODEWITHSUNDEEP
vbaexcel
Adam Campbell
Adam Campbell

Reputation: 1

Trying to copy column, based on header, from one workbook to another

I am trying to have VBA open up a selected workbook and copy the column of data based on the heading "RGRD". The code fails after selecting the EntireColumn with a Run Time Error 424. I would prefer to copy down until the last non empty cell in the column. 

Sub test()

Dim wkbCrntWorkBook As Workbook
Dim wkbSourceBook As Workbook

Dim rngSourceRange As Range
Dim rngDestination As Range
Dim rngTest1 As Range

Dim strFindThis As String

Set wkbCrntWorkBook = ActiveWorkbook

'Opens prompt to select Source file
With Application.fileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Excel 2007", "*.xlsx; *.xlsm; *.xlsa", 1
.Filters.Add "Excel 2002-03", "*.xls", 2
.AllowMultiSelect = False
.Show

If .SelectedItems.Count > 0 Then
    Workbooks.Open .SelectedItems(1)

    Set wkbSourceBook = ActiveWorkbook

    'Code searches for key word
    strFindThis = "RGRD"
    Set rngSourceRange = Application.Range("A1:BZ1").Find(What:=strFindThis, Lookat:=xlPart, MatchCase:=False)

    'Selects entire column based on key word header
    Set rngTest1 = rngSourceRange.EntireColumn.Select

    'Swicthes to UMD Price Out Worksbook
    wkbCrntWorkBook.Activate

    'Copies column data from Source to Cell B1 on UMD Price Out Workbook
    Set rngDestination = ActiveSheet.Cells(1, 2)
    rngTest1.Copy rngDestination

    'Formats column to AutFit and Closes Source Worksbook
    rngDestination.CurrentRegion.EntireColumn.AutoFit
    wkbSourceBook.Close False

End If
End With
End Sub

Upvotes: 0

Views: 53

Answers (2)

paul bica
paul bica

Reputation: 10715

The issue is on this line:

Set rngTest1 = rngSourceRange.EntireColumn.Select

One statement can execute only one action, but this line performs 2, generating the error:

  • rngSourceRange.EntireColumn.Select - this selects the column
  • Set rngTest1 = ... - this attempts to set the range object

To fix your code just remove .Select

In the code bellow I use more descriptive variable names, eliminated the Select and Activate actions, and check that the string (column) is found

Option Explicit

Public Sub CopyRGRD()
    Const FIND_STR = "RGRD"

    Dim destWb As Workbook, srcWb As Workbook, srcUR As Range, destCell As Range
    Dim foundCell As Range, foundCol As Range

    Set destWb = Application.ThisWorkbook   'File where the code executes

    With Application.FileDialog(msoFileDialogOpen)
        .Filters.Clear
        .Filters.Add "Excel 2007", "*.xlsx; *.xlsm; *.xlsa", 1
        .Filters.Add "Excel 2002-03", "*.xls", 2
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then
            Application.ScreenUpdating = False
            Set srcWb = Workbooks.Open(.SelectedItems(1))
            Set srcUR = srcWb.Worksheets(1).UsedRange   'Sheet1 in selected file

            Set foundCell = srcUR.Rows(1).Find(What:=FIND_STR, _
                                               Lookat:=xlPart, MatchCase:=False)

            If Not foundCell Is Nothing Then    'Make sure that column RGRD exists
                Set foundCol = srcUR.Columns(foundCell.Column).EntireColumn
                Set destCell = destWb.ActiveSheet.Cells(1, 2)
                foundCol.Copy destCell
                destCell.EntireColumn.AutoFit
            End If
            srcWb.Close False
            Application.ScreenUpdating = True
        End If
    End With
End Sub

Upvotes: 1

elliot svensson
elliot svensson

Reputation: 603

If you are running Excel 2010 or later, try formatting your data as a Table, using Insert > Table!!!

Table

This makes your data into a growing ActiveSheet.Listobject which has all kinds of features in VBA that you can use, including a pre-calculated number of rows.

Upvotes: 0

Related Questions