Macro to open wokbook and only copy certain columns

[howard]

I have a macro below that opens a workbook and copies the data.


However the fields in the import data changes from time to time i.e. extra fields are added


I need my code altered so that only columns containing the following headings in row 1 are copied



Stock Number Order Number Registration Number Make

 Sub Open_Workbook()
ChDir ("C:\extract")

     With Sheets("Vehicles")
     .Range("A1:AO500").ClearContents
     End With
     
    Dim nb As Workbook, ts As Worksheet, A As Variant
    Dim rngDestination As Range
    
    Set ts = ActiveSheet
    With Sheets("Vehicles")
    .Select
    End With
    
    On Error Resume Next
    Set rngDestination = Application.Range("'vehicles'!A1")
    
    On Error GoTo 0
   If rngDestination Is Nothing Then Exit Sub  'User canceled
    
    A = Application.GetOpenFilename
    If A = False Or IsEmpty(A) Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Set nb = Workbooks.Open(Filename:=A, local:=True)
    ThisWorkbook.Activate
    
    nb.Sheets(1).Range("A:AO").Copy
    rngDestination.PasteSpecial Paste:=xlPasteValues
    rngDestination.PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
  
    nb.Close savechanges:=False 'Close the source workbook
     
    
    
End Sub

your assistance in this regard is most appreciated

 

[KennyGreens]

Hi there, this is probably not the best method (and I'm sure someone will post a different method), but it's certainly one way to do this. I'm a fan of using arrays when you need to look for multiple values through a sheet with solid amount of data. I apologize for the weird formatting, I'm on mobile and had some trouble copy-pasting. Credit to a user on stackoverflow for the IsInArray function, I use it relatively frequently and had it saved for a while. I have not tested this, so please let me know of any issues.

Function IsInArray(stringToBeFound As String, arr As Variant) As Long
  Dim i As Long
  ' default return value if value not found in array
  IsInArray = -1

  For i = LBound(arr) To UBound(arr)
    If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
      IsInArray = i
      Exit For
    End If
  Next i
End Function

Sub Open_Workbook()
ChDir ("C:\extract")

WithSheets("Vehicles")
.Range("A1:AO500").ClearContents
End With

Dim nb AsWorkbook, ts As Worksheet, A As Variant
Dim rngDestinationAs Range
Dim i As Integer
Dim lcol As Long
Dim headName As Variant
Dim x As Integer

Set ts =ActiveSheet
WithSheets("Vehicles")
.Select
End With

On Error ResumeNext
Set rngDestination= Application.Range("'vehicles'!A1")

On Error GoTo 0
If rngDestinationIs Nothing Then Exit Sub'User canceled

A =Application.GetOpenFilename
If A = False OrIsEmpty(A) Then Exit Sub

Application.ScreenUpdating = False

Set nb =Workbooks.Open(Filename:=A, local:=True)
ThisWorkbook.Activate

lcol = nb.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column

headName = Split("Stock Number,Order Number,Registration Number,Make", ",")

x = 0

For i = 1 To lcol
If IsInArray(nb.Sheets(1).Cells(1, i), headName) > -1 Then
nb.Sheets(1).Columns(i).Copy
rngDestination.Offset(0, x).PasteSpecial Paste:=xlPasteValues
rngDestination.Offset(0, x).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
x = x + 1
End If
Next i


nb.Close savechanges:=False'Close the source workbook




End Sub

 

[howard]

Thanks Kenny. I made a few changes to the formatting and your code works perfectly


I appreciate your help as this will help me tremendously

 

[KennyGreens]

Thanks Kenny. I made a few changes to the formatting and your code works perfectly


I appreciate your help as this will help me tremendously

No problem friend.