Excel 2010 VBA transfer multicolumn Список для именованного диапазона

Question

У меня есть sub, который я хочу использовать для копирования элементов из многоколоночного списка в именованный диапазон в электронной таблице. Часть sub, с которой у меня возникают проблемы, прокомментирована как «Переход к таблице» (см. Ниже). Он не копирует мой именованный диапазон («Import_Items» или «Export_Items», которые ссылаются на определенные таблицы в зависимости от того, какой лист используется в качестве источника), а вместо этого копирует строку 1, начиная с столбца C. Я чувствую, что я вероятно, пропуская что-то очень простое, любая помощь будет оценена по достоинству.

Sub Transfer() 
Dim CopyToWB As Workbook 
Dim ASName As String 
Dim lItem As Long, lRows As Long, lCols As Long 
Dim lColLoop As Long, lTransferRow As Long 

Set CopyToWB = Workbooks.Open(FPath & "\" & FName) 
ASName = ActiveSheet.Name 
lRows = ItemsLB.ListCount - 1 
lCols = ItemsLB.ColumnCount - 1 

With CopyToWB.Sheets(ASName) 
    Range(ASName & "_Date") = DateTB 
    Range(ASName & "_Tool_Order") = ToolOrderTB 
    Range(ASName & "_WAY_BILL") = TrackingTB 
    Range(ASName & "_TPOC_Name") = TPOCNameTB 
    Range(ASName & "_Site") = SiteTB 
    Range(ASName & "_Street") = StreetTB 
    Range(ASName & "_City_State") = CityStateTB 
    Range(ASName & "_Zip") = ZipTB 
    Range(ASName & "_SPOC_Name") = SPOCNameTB 
    Range(ASName & "_SPOC_Phone") = PhoneTB 
    Range(ASName & "_SPOC_Email") = SPOCEmailTB 
    Range(ASName & "_TPOC_Email") = TPOCEmailTB 


    'Transfer to table 
    With Range(ASName & "_Items", ActiveSheet.Cells(lRows + 1, 4 + lCols)) 'Transfer to range 
     For lItem = 0 To lRows 
      'Increment variable for row transfer range 
      lTransferRow = lTransferRow + 1 
       'Loop through columns of selected row 
       For lColLoop = 0 To lCols 
       'Transfer selected row to relevant row of transfer range 
       .Cells(lTransferRow, lColLoop + 1) = ItemsLB.List(lItem, lColLoop) 
       Next lColLoop 
     Next 
    End With 

    'Export/Import-dependent 
    If ASName = "Export" Then 
     Range(ASName & "_TPOC_Print_Name") = TPOCNameTB 
     Range(ASName & "_TPOC_Title") = TPOCTitleTB 
    ElseIf ASName = "Import" Then 
     Range(ASName & "_Consignee_Name_Number") = TPOCNameTB & _ 
      " - " & TPOCPhoneTB 
    End If 

    Application.DisplayAlerts = False 
    .SaveAs FPath & FName 

    'Optional export to PDF 
    If PDFChkBx = True Then 
     ActiveSheet.ExportAsFixedFormat _ 
      Type:=xlTypePDF, _ 
      Filename:=FPath & "Proforma Customs Invoice " & ToolOrderTB.Value & ".pdf", _ 
      Quality:=xlQualityStandard, _ 
      IncludeDocProperties:=True, _ 
      IgnorePrintAreas:=False, _ 
      OpenAfterPublish:=True 
    End If 

    Application.DisplayAlerts = True 
End With 

End Sub

Answer 1

Это как удалить весь список в диапазоне на одном дыхании:

With Me.ItemsLB 
    Range(ASName & "_Items").Resize(.ListCount, .ColumnCount).Value = .List 
End With 

Вот пример явного изменения размера таблицы:

Dim lo As ListObject 

With Me.ItemsLB 
    Set lo = Range(ASName & "_Items").ListObject 
    lo.Resize lo.Range.Resize(.ListCount + 1, .ColumnCount) 
    lo.DataBodyRange.Value = .List 
End With