二行变一行

物理作业是啥

1 2 3

4 5 6

变成 1 2 3 4 5 6

有一千多行

以上描述错误
A b  c
1 2 3
4 5 6
a b c d e f
1 2 3 4 5 6

数据存第一行原位置
第二行删除

附件时，表一，变，表二

quqiyuan

大概这样，仅供参考。。。

海好呀

上传附件可能会解决起来方便点

quqiyuan

代码如下。。。
Sub test()
    r = Sheet1.Cells(Rows.Count, 1).End(3).Row
    arr = Sheet1.[a1].Resize(r)
    ReDim brr(1 To UBound(arr) / 2 + 1, 1 To 1)
    n = 0
    For i = 1 To r Step 2
        n = n + 1
        brr(n, 1) = arr(i, 1) & arr(i + 1, 1)
    Next
    Sheet1.[c1].Resize(n) = brr
    Beep
End Sub

gwjkkkkk

请参考。。。

gwjkkkkk

请参考附件。。。

物理作业是啥

gwjkkkkk 发表于 2024-10-18 20:00
请参考附件。。。

大佬，在帮看一下。我原以为从后向前合并一行删一行，你用数组或字典再在一个新表从新输出也行。我以前应该会，太长时间不出了。

物理作业是啥

Sub test()
    Dim arrarr As Variant, a As Integer
    a = Sheets("Sheet1").Range("A65536").End(3).Row
     Set d = CreateObject("Scripting.Dictionary")
    arr = Sheets("Sheet1").Range("A1:J" & a)
    ReDim arrarr(1 To Int(a / 3) + 1, 1 To 30)
     
     For i = 1 To UBound(arr)
        If i Mod 3 = 1 Then
          For j = 1 To 10
          arrarr(Int(i / 3) + 1, j) = arr(i, j)
          Next
        End If
         If i Mod 3 = 2 Then
          For j = 1 To 10
           arrarr(Int(i / 3) + 1, j + 10) = arr(i, j)
           Next
   
        End If
                 If i Mod 3 = 0 Then
          For j = 1 To 10
         
         arrarr(Int(i / 3), j + 20) = arr(i, j)
         
          Next
   
        End If
     Next

Sheets("Sheet2").Range("A1").Resize(UBound(arrarr), 30) = arrarr
End Sub


有点笨，自己解决了