如何使用公共标识符在A1:A8下复制和粘贴范围,该标识符在一行中的8列数据集的开头重复

数据集示例

A      B     c      D     E     F    G       H         I     J     K      L    M     N      O    P
-10    5     16     23    8     2    6       3162625  -10    5     16     23   8     2      6    3162626

所需的输出

A      B     C      D     E     F    G       H         I     J     K      L    M     N      O    P
-10    5     16     23    8     2    6       3162625 
-10    5     16     23    8     2    6       3162626

常数为-10,之后需要7列

使用VBA,我可以将列A转移到H到另一张纸上,但是我无法使VBA移到列I,Q等

我拥有的VBA是

Sub search_and_extract_singlecriteria()
'1.
'2.
'3.

Dim datasheet As Worksheet
Dim reportsheet As Worksheet
Dim recordid As String
Dim finalrow As Integer
Dim i As Integer

Set datasheet = Sheet1
Set reportsheet = Sheet2
recordid = "-46" 'reportsheet.Range("B2").Value

'reportsheet.Range("A1:L100").ClearContents

datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row


For i = 1 To finalrow
    If Cells(i, 1) = recordid Then
        Range(Cells(i, 9), Cells(i, 17)).Copy
        reportsheet.Select
        Range("A200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
        datasheet.Select
        End If
Next i

reportsheet.Select

Range("B2").Select

End Sub

简单复制和粘贴不是一种选择,因为一行上有8列,重复了1000列。每行具有不同的列长。如果可以做到的话,我最终将得到300k加8列A:H的行 任何建议将不胜感激。

评论
  • Ken
    Ken 回复

    尝试这个。添加了一些注释来解释。

    如果速度较慢,则使用数组的效率更高。

    Sub x()
    
    Dim r As Range
    
    application.screenupdating=false
    
    Set r = Sheet1.Range("A1").Resize(, 8) 'set starting range 1 x 8
    
    Do Until IsEmpty(r(1)) 'keep doing this until first cell is empty
        r.Copy Sheet2.Range("A" & Rows.Count).End(xlUp)(2) 'copy to first blank cell in A sheet2
        Set r = r.Offset(, 8) 'move copy range along by 8 cells to the right
    Loop
    
    application.screenupdating=true
    
    End Sub