行列转换

Aggime

求各位大神帮忙，我想把附件里Sheet1两列的数据转换成Sheet2格式（如下图左边两列数据变成右边图二 四行的数据）。求各位大神老师帮忙，谢谢！

            

shiruiqiang

判断行（a）=图片号，列=列+3
或者 局部复制过去

Aggime

shiruiqiang 发表于 2024-11-15 20:10
判断行（a）=图片号，列=列+3
或者 局部复制过去

大神可以写个代码演示下吗，感谢！

shiruiqiang

shiruiqiang

复制代码

翁知江安

Sub zhuanzhi()
Dim i, j, k, m, p, irow
Dim arr, brr
irow = Sheet1.[b65336].End(xlUp).Row
arr = Sheet1.Range("a1:c" & irow)
For i = 3 To irow
  If arr(i, 1) = "圆片号" Then
  j = j + 1
  arr(i, 3) = j
  End If
  If arr(i - 1, 3) <> "" And arr(i, 3) = "" Then
  arr(i, 3) = arr(i - 1, 3)
  End If
Next
ReDim brr(1 To 100, 1 To 100)
brr(1, 1) = arr(3, 1)
brr(1, 2) = arr(3, 2)
brr(1, 3) = ""
p = 1
For k = 4 To irow
  If arr(k - 1, 3) = arr(k, 3) Then
    p = p + 1
  brr(p, arr(k, 3) * 3 - 2) = arr(k, 1)
  brr(p, arr(k, 3) * 3 - 1) = arr(k, 2)
  brr(p, arr(k, 3) * 3) = ""
    Else
    p = 1
    brr(p, arr(k, 3) * 3 - 2) = arr(k, 1)
    brr(p, arr(k, 3) * 3 - 1) = arr(k, 2)
    brr(p, arr(k, 3) * 3) = ""
    End If
Next
Sheet2.[a40].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

翁知江安

仅供参考。欢迎批评指正

gwjkkkkk

Option Explicit
Sub test()
    Dim ar(), br, i&, j&, r&, n&, isFalg As Boolean, iPosCol&
    With Worksheets(1)
        n = .Cells(.Rows.Count, "B").End(xlUp).Row
        With .Range("A3:B" & n) 'Value
        br = .Value
        For i = 1 To UBound(br) Step 35
            r = r + 1
            ReDim Preserve ar(1 To r)
            Set ar(r) = .Cells(i, 1).CurrentRegion
            'ar(r).Select
        Next i
        End With
    End With
    With Worksheets(2)
        .Cells.Clear
        For j = 1 To UBound(ar)
            iPosCol = (j - 1) * 3 + 1
            ar(j).Copy .Cells(1, iPosCol)
        Next j
        .Activate
    End With
End Sub

gwjkkkkk

请参考。。。