将多个单元格（不是并排）复制到并排的单元格

Question

得到这个代码：

Sub LoopAllFilesAndCopyPasteKIT()
    
    Dim MyObj As Object
    Dim MySource As Object
    Dim file As Variant
    
    Dim wbThis                  As Workbook     'Denne fila
    Dim wbTarget                As Workbook     'Filer å kopiere data fra
    Dim LastRow As Long
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    
    Dim vDB As Variant
    
    Set wbThis = ActiveWorkbook
    Set sht1 = wbThis.Sheets("Ark1")
    
    Folder = "H:\Mine dokumenter\Nedlastinger\Rapporter\"
    Fname = Dir(Folder)
    
    While (Fname <> "")
    
        Set wbTarget = Workbooks.Open(Filename:=Folder & Fname)
      
        vDB = wbTarget.Sheets(1).Range("A3:D3")
    
        sht1.Range("A" & Rows.Count).End(xlUp)(2).Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
    
        Fname = Dir
    
        'Lukke rapportfilen
        wbTarget.Close
    Wend
    
End Sub

代码打开文件夹中的所有文件并将单元格复制到“masterWb”，将数据放在下一个空行中。
目标范围设置为“A3:D3”（单元格并排）。

我想复制单元格 B3、G3、B7 和 R7。

我试过了：

vDB = wbTarget.Sheets(1).Range("B3,G3,B7,R7")

下面的粘贴代码给我一个错误。

Answer 1

请尝试下一个功能。它会将不连续的范围转换为连续的一维数组：

Function testUnionDiscontinuousRangeArray(rng As Range, sep As String) As Variant
  Dim arr As Variant, arrF As Variant, arr1 As Variant
  Dim temp As String, i As Long, j As Long
  
   arr = Split(rng.Address, ",")

   For i = 0 To UBound(arr)
    arr1 = rng.Parent.Range(arr(i)).Value
    If IsArray(arr1) Then
        For j = 1 To UBound(arr1)
           temp = temp & Join(Application.Index(arr1, j, 0), sep) & sep
        Next
    Else
        temp = temp & arr1 & sep
    End If
   Next
   temp = left(temp, Len(temp) - 1)
   testUnionDiscontinuousRangeArray = Split(temp, sep)
End Function

你可以先这样测试：

Sub testUnionDiscRange()
  Dim rng As Range, arr1Row As Variant
  Set rng = Range("B3,G3:I3,B7,R7") 'it works on active worksheet
  arr1Row = testUnionDiscontinuousRangeArray(rng, "|")
  Debug.Print Join(arr1Row, "|")
End Sub

它将return所有数组值用“|”分隔。

您可以在您的代码中使用它，方法是：

将上述函数复制到与主代码相同的模块中。
替换：

vDB = wbTarget.Sheets(1).Range("A3:D3")
   sht1.Range("A" & Rows.Count).End(xlUp)(2).Resize(UBound(vDB, 1), UBound(vDB, 2)) = vD

与：

Dim rngvDB as range
 Set rngvDB = wbTarget.Sheets(1).Range("B3,G3,B7,R7")
 vDB = testUnionDiscontinuousRangeArray(rngvDB, "|")
  ' then use your way of copying the array, but adapted for 1D array type:
 sht1.Range("A" & Rows.Count).End(xlUp)(2).Resize(1, UBound(vDB) + 1) = vDB

已编辑:

要计算真正的最后一个空行，如果某些粘贴的单元格值中有空值，请使用下一个函数：

Function LastEmptyR(sh As Worksheet, ColNo As Long) As Long
   Dim lastR As Long, i As Long
   For i = 1 To ColNo
       If sh.cells(rows.count, i).End(xlUp).row > lastR Then
            lastR = sh.cells(rows.count, i).End(xlUp).row
       End If
   Next i
   LastEmptyR = lastR + 1
End Function

可以通过这种简单的方式进行测试：

Sub testLastEmptyR()
  Debug.Print LastEmptyR(ActiveSheet, 5) '5 = number of columns to be used
End Sub

您将把它用作 sht1.Range("A" & LastEmptyR).Resize(1, UBound(vDB) + 1) = vDB

将多个单元格（不是并排）复制到并排的单元格

Copy multiple cells, not side by side, to cells that are side by side

excel

vba

copy-paste