将来自不同工作表的两个范围添加到表中

时间:2018-08-26 23:27:56

标签: excel vba

我在两个不同的变量中设置了两个范围。尝试将一个插入表格,然后将另一个插入表格下方。在插入之前,我需要它删除表的数据主体(而不是删除表)。然后我需要插入范围。

当前存在的问题:

  1. 获取错误方法'删除对象'_worksheet有时会失败 删除图纸(如果已存在)时首次运行。错误 似乎没有第二次运行。

  2. 将NewData复制到表仅插入rng1的第一行。我需要 到复制到表的整个范围,不包括其中值是“ N”的行 A列。如何将整个范围复制到表格中?

    Option Explicit
    
    Sub AddDataRow(tableName As String, NewData As Range)
    Dim sheet As Worksheet
    Dim table As ListObject
    Dim col As Integer
    Dim lastRow As Range
    
    
    Set sheet = Range(tableName).Parent
    Set table = sheet.ListObjects.Item(tableName)
    
    'First check if the last table row is empty; if not, add a row
    If table.ListRows.Count > 0 Then
        Set lastRow = table.ListRows(table.ListRows.Count).Range
        If Application.CountBlank(lastRow) < lastRow.Columns.Count Then
            table.ListRows.Add
        End If
    End If
    
    'Copy NewData to new table record
    Set lastRow = table.ListRows(table.ListRows.Count).Range
    lastRow.Value = NewData.Value
    End Sub
    
    
    Sub CopyToDataset()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim destWkb As Workbook
    Dim sh As Worksheet
    Dim destSh As Worksheet
    Dim destSh1 As Worksheet
    Dim destSh2 As Worksheet
    Dim cell As Range, rng1 As Range, rng2 As Range, row As Range
    Dim copyRng As Range
    Dim LastRowDestSh1 As Long
    Dim LastRowDestSh2 As Long
    Dim LastRowDestSh As Long
    Dim myTable As ListObject
    Dim oNewRow As ListRow
    
    'set source variables
    Const startRow As Long = 6
    Set ws1 = Sheet1 'worksheet "A Jobs"
    Set ws2 = Sheet2 'worksheet "ACC Job Schedule"
    Set destWkb = Workbooks("Job Income Summary Export.xlsm")
    Set destSh = destWkb.Worksheets("Dataset")
    
    'delete worksheets if they already exists in destination workbook
    For Each sh In destWkb.Worksheets
        If (sh.Name = ws1.Name Or sh.Name = ws2.Name) And sh.Name <> destSh.Name _
        Then
            sh.Delete  '**getting error method 'Delete of object '_worksheet failed sometimes on first run
        End If
    Next sh
    
    'copy source worksheets into destination workbook
    ws1.Copy After:=destWkb.Sheets(destWkb.Sheets.Count)
    ws2.Copy After:=destWkb.Sheets(destWkb.Sheets.Count)
    
    'destination workbook set variables
    Set destSh1 = destWkb.Worksheets("A JOBS")
    Set destSh2 = destWkb.Worksheets("ACC Job Schedule")
    Set myTable = destSh.ListObjects("desttbl")
    'Set oNewRow = myTable.ListRows.Add(AlwaysInsert:=True)
    
    'Find the last non-blank cell in column A(1)
    LastRowDestSh1 = destSh1.Cells(Rows.Count, 1).End(xlUp).row
    Debug.Print (LastRowDestSh1) 'last row is 406
    LastRowDestSh2 = destSh2.Cells(Rows.Count, 1).End(xlUp).row
    Debug.Print (LastRowDestSh2) 'last row is 182
    LastRowDestSh = lastRow(destSh)
    Debug.Print (LastRowDestSh) 'last row is 1
    
    Set rng1 = destSh1.Range("A7:AD7", destSh1.Cells(LastRowDestSh1, 32))
    Set rng2 = destSh2.Range("A7:AD7", destSh2.Cells(LastRowDestSh2, 32))
    
    'Clear table contents
    With myTable.DataBodyRange
        On Error Resume Next
        .Rows(1).ClearContents
        .Offset(1, 0).Resize(.Rows.Count - 1, _
        .Columns.Count).Rows.Delete
        On Error GoTo 0
    End With
    
    'Copy NewData[rng1 and rng2] NewData to new table record
    'If UCase(rng1.Cells(cell.row, "A").Value) = "Y"
    
    
            AddDataRow "desttbl", [rng1] 'only first row is copying to table.
    
    
    Application.GoTo destSh.Cells(2, 1)
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    End Sub
    

0 个答案:

没有答案