vba specific Columns - Dynamically

Mallesh23

Well-known Member
Joined
Feb 4, 2009
Messages
837
Office Version
  1. 2010
Platform
  1. Windows
Hi Team,

I want to copy specific headers . Below code copy 3 headers from array value.
I want your help in creating function if in future,columns to Copy Increases it should cover. any other method I am ok. like dictionary

Needs to make this line dynamic by creating a function :=> Array(1, 5, 10))

Sub working code
Dim ar As Variant
ar = Sheet1.Range("A1:Z19").value
Sheet2.Range("A1").Resize(UBound(Ar), 3).Value = Application.Index(Ar, Evaluate("Row(1:" & UBound(Ar) & ")"), Array(1, 5, 10))
end sub


My attempted Code...

Rich (BB code):
Sub Copy_Columns()

    Dim headerName As String
  headerName = "Region,Due Date,Invoice No,Delivery Date,Document Date"  ' Headers to Copy

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)
    
    Dim ar As Variant
    
'Call function
  ar = HeaderCopy(ws, headerName, 1)
        
    Sheet2.Range("A1").Resize(UBound(ar), 3).Value = Application.Index(ar, Evaluate("Row(1:" & UBound(ar) & ")"), Array(10, 5, 1))
    
End Sub

Function HeaderCopy(ByVal ws As Worksheet, headerName As String, Optional ByVal hrow As Long = 1) As Variant

     Dim rg As Range
    Set rg = ws.Range("A1").CurrentRegion
    
    Dim myarray As Variant
    'myarray = rg.Value
    'Dim dict As New Scripting.Dictionary
    
    Dim Arr_header As Variant
    Arr_header = Split(headerName, ",")
        
    Dim m As Variant
    Dim i As Long
    
    For i = 0 To UBound(Arr_header,1)
        m = Application.Match(Arr_header(i), ws.Rows(hrow), 0)
         myarray(i) = m  'getting error type mismatch.
        
    Next i
 
        HeaderCopy = myarray
   
    End Function
 

Some videos you may like

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,881
I got you part of the way there with the following code, but I do not understand what you want to do in this line:
VBA Code:
Sheet2.Range("A1").Resize(UBound(ar), 3).Value = Application.Index(ar, Evaluate("Row(1:" & UBound(ar) & ")"), Array(10, 5, 1))

VBA Code:
Option Explicit

Sub Copy_Columns()

    Dim headerName As String
    headerName = "Region,Due Date,Invoice No,Delivery Date,Document Date"  ' Headers to Copy

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)
    
    Dim ar As Variant
    
'Call function
    ar = HeaderCopy(ws, headerName, 1)
        
    Sheet2.Range("A1").Resize(UBound(ar), 3).Value = Application.Index(ar, Evaluate("Row(1:" & UBound(ar) & ")"), Array(10, 5, 1))
    
End Sub

Function HeaderCopy(ByVal ws As Worksheet, headerName As String, Optional ByVal hrow As Long = 1) As Variant
    Dim rg As Range
    Set rg = ws.Range("A1").CurrentRegion
    
    Dim myarray() As Variant
    Dim sOutput As String
    Dim lGoodHeader As Long
    
    Dim Arr_header As Variant
    Arr_header = Split(headerName, ",") '0-based array
        
    Dim m As Variant
    Dim i As Long
    
    ReDim myarray(1 To UBound(Arr_header) + 1) '1-based array
    
    For i = 0 To UBound(Arr_header, 1)
        m = Application.Match(Arr_header(i), ws.Rows(hrow), 0)
        If Not IsError(m) Then
            lGoodHeader = lGoodHeader + 1
            myarray(lGoodHeader) = m 'getting error type mismatch.
        Else
            sOutput = sOutput & ", " & Arr_header(i)
        End If
        
    Next i
    
    ReDim Preserve myarray(1 To lGoodHeader)
    If sOutput <> vbNullString Then
        sOutput = Mid(sOutput, 3)
        MsgBox "The following headers were not found in row " & hrow & " of Sheet1" & vbLf & vbLf & sOutput
    End If
    
    HeaderCopy = myarray
   
End Function
 

Watch MrExcel Video

Forum statistics

Threads
1,122,246
Messages
5,595,044
Members
413,963
Latest member
teggl97

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top