非连续命名范围到数组中，然后进入不同工作表中的行

Question

我试图将数据从非连续范围发布到单独的工作表中的行中。在我构建非连续范围之前，这段代码完美无缺。我已经尝试了几个循环，但我尝试的任何东西都不会起作用。它不会复制远程数据。自从我实际完成任何编码以来已经好几年了，而且我的重新学习曲线似乎阻碍了我......逻辑并没有来到我身边。救命啊！

Sub UpdateLogWorksheet()

Dim historyWks As Worksheet
Dim inputWks As Worksheet

Dim nextRow As Long
Dim oCol As Long

Dim myCopy As Range
Dim myTest As Range
Dim myData As Range

Dim lRsp As Long

Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("DataEntry")
oCol = 3 'order info is pasted on data sheet, starting in this column

'check for duplicate VIN in database
If inputWks.Range("CheckVIN") = True Then
  lRsp = MsgBox("VIN already in database. Update record?", vbQuestion + vbYesNo, "Duplicate VIN")
  If lRsp = vbYes Then
    UpdateLogRecord
  Else
    MsgBox "Please change VIN to a unique number."
  End If

Else

  'cells to copy from Input sheet - some contain formulas

  Set myCopy = inputWks.Range("VehicleEntry") 'non-contiguous named range

  With historyWks
      nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
  End With

  With inputWks
      'mandatory fields are tested in hidden column
      Set myTest = myCopy.Offset(0, 2)

      If Application.Count(myTest) > 0 Then
          MsgBox "Please fill in all the cells!"
          Exit Sub
      End If
  End With

  With historyWks
      'enter date and time stamp in record
      With .Cells(nextRow, "A")
          .Value = Now
          .NumberFormat = "mm/dd/yyyy hh:mm:ss"
      End With
      'enter user name in column B
      .Cells(nextRow, "B").Value = Application.UserName
      'copy the vehicle data and paste onto data sheet

      myCopy.Copy
      .Cells(nextRow, oCol).PasteSpecial Paste:=xlPasteValues, Transpose:=True
      Application.CutCopyMode = False
  End With

  'clear input cells that contain constants
  Clear
End If

End Sub

Answer 1

这是一个示例，用于解释如何实现您的目标。请修改代码以满足您的需求。

让我们说，我有一个Sheet1，如下所示。有色细胞由我不连续的范围构成。

现在将下面给出的代码粘贴到模块中并运行它。输出将在Sheet2和Sheet3

中生成

<强>代码

Sub Sample()
    Dim rng As Range, aCell As Range
    Dim MyAr() As Variant
    Dim n As Long, i As Long

    '~~> Change this to the relevant sheet
    With Sheet1
        '~~> Non Contiguous range
        Set rng = .Range("A1:C1,B3:D3,C5:G5")

        '~~> Get the count of cells in that range
        n = rng.Cells.Count

        '~~> Resize the array to hold the data
        ReDim MyAr(1 To n)

        n = 1

        '~~> Store the values from that range into
        '~~> the array
        For Each aCell In rng.Cells
            MyAr(n) = aCell.Value
            n = n + 1
        Next aCell
    End With

    '~~> Output the data in Sheet

    '~~> Vertically Output to sheet 2
    Sheet2.Cells(1, 1).Resize(UBound(MyAr), 1).Value = _
    Application.WorksheetFunction.Transpose(MyAr)

    '~~> Horizontally Output to sheet 3
    Sheet3.Cells(1, 1).Resize(1, UBound(MyAr)).Value = _
    MyAr
End Sub

垂直输出

横向输出

希望上面的例子可以帮助你实现你想要的目标。