Vba excel данные с одного столбца в столбец

    Dim my_range As Range
    Set my_range = Range("A1", "D1").Find(What:="Date", LookIn:=xlValues, MatchCase:=False)

Sub CopySpecifcColumn()
    Dim Pos         As Long
    Dim vHeader     As Variant
    Dim rngFound1 As Range, rngFound2 As Range
    Dim ArryHeader1() As String, ArryHeader2() As String
    Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = ActiveWorkbook.Sheets(1)
    Set ws2 = ActiveWorkbook.Sheets(2)

    ArryHeader1 = Split("Date", ",")   ' Здесь можете задать несколько заголовков столбцов, через запятую вписываете заголовок (Лист исходник)
    ArryHeader2 = Split("Date", ",")   ' Здесь можете задать несколько заголовков столбцов, через запятую вписываете заголовок (Лист назначения)

    Application.ScreenUpdating = False

    For Each vHeader In ArryHeader1
        Set rngFound1 = ws1.Cells.Find(vHeader, , xlValues, xlWhole, 1, 1, 0)

        If Not rngFound1 Is Nothing Then
            Pos = Application.Match(vHeader, ArryHeader1, False) - 1
            Set rngFound2 = ws2.Cells.Find(ArryHeader2(Pos), , xlValues, xlWhole, 1, 1, 0)

            '            ' Вставка без форматов ячеек
            '            Range(rngFound1.Offset(1), rngFound1.End(xlDown)).Copy
            '            rngFound2.Offset(1).PasteSpecial xlPasteValues

            ' Копирования столбца и вставка с форматом ячеек
            Range(rngFound1.Offset(1), rngFound1.End(xlDown)).Copy Destination:=rngFound2.Offset(1)
        End If

    Next

    ws2.Select.  ' Можете закоментировать строку если не нужна активация второго листа (лист назначения)
    Application.ScreenUpdating = True
 End Sub

Sub CopySameColumns()
  Dim dc, c, i&, rg As Range, ws As Worksheet
  Set dc = CreateObject("Scripting.Dictionary")
  For Each c In Array("Date", "Name", "ID", "Amound")
    dc(c) = 0
  Next
  Set ws = Worksheets(1)
  For i = 1 To ws.Cells(1, Columns.Count).End(xlToLeft).Column
    If dc.Exists(ws.Cells(1, i).Value) Then
      dc(ws.Cells(1, i).Value) = i
      Set rg = ws.Cells(Rows.Count, i).End(xlUp)
      If rg.Row > 1 Then Range(ws.Cells(2, i), rg).ClearContents
    End If
  Next
  For Each c In dc.keys
    If dc(c) = 0 Then dc.Remove c
  Next
  With Worksheets(2)
    For i = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
      If dc.Exists(.Cells(1, i).Value) Then
        Set rg = .Cells(Rows.Count, i).End(xlUp)
        If rg.Row > 1 Then
          Range(.Cells(2, i), .Cells(Rows.Count, i).End(xlUp)).Copy _
          ws.Cells(2, dc(.Cells(1, i).Value))
        End If
      End If
    Next
  End With
End Sub

Option Explicit

Sub CopySpecifcColumn_v3()
    Dim Pos         As Long
    Dim vHeader     As Variant
    Dim rngFound1 As Range, rngFound2 As Range
    Dim ArryHeader1() As String, ArryHeader2() As String
    Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = ActiveWorkbook.Sheets(1)
    Set ws2 = ActiveWorkbook.Sheets(2)

    ArryHeader1 = Split("Date,Pon", ",")   ' Здесь можете задать несколько заголовков столбцов, через запятую вписываете заголовок (Лист исходник)
    ArryHeader2 = Split("Date,Pon", ",")   ' Здесь можете задать несколько заголовков столбцов, через запятую вписываете заголовок (Лист назначения)

    Application.ScreenUpdating = False

    For Each vHeader In ArryHeader2
        Set rngFound1 = ws1.Cells.Find(vHeader, , xlValues, xlWhole, 1, 1, 0)

        If Not rngFound1 Is Nothing Then
            Pos = Application.Match(vHeader, ArryHeader2, False) - 1
            Set rngFound2 = ws2.Cells.Find(ArryHeader1(Pos), , xlValues, xlWhole, 1, 1, 0)

            ' Копирования столбца и вставка с форматом ячеек
            Range(rngFound2.Offset(1), rngFound2(Rows.Count).End(xlUp)).Copy Destination:=rngFound1.Offset(1)
        End If

    Next

    Application.ScreenUpdating = True
    MsgBox "А теперь Правильно? ", vbQuestion
End Sub