VBA 编写，把其余列的内容都剪切黏贴到A列下面

zx6091024

见附件，要求都写在附件里，感谢各位大佬。

limonet

新函数：=TOCOL(A1:G7,3,1)

huanghai22

2010版本表示参与一下

limonet

关键字：if

limonet

Sub limonet()
    Dim Arr As Variant, i%, j%, k%, Brr() As Variant
    Arr = Range("A1").CurrentRegion.Value
    For i = 1 To UBound(Arr, 2)
        For j = 1 To UBound(Arr)
            If Arr(j, i) <> "" Then
                k = k + 1
                ReDim Preserve Brr(1 To k)
                Brr(k) = Arr(j, i)
            End If
        Next j
    Next i
    Range("I1").Resize(UBound(Brr)) = Application.Transpose(Brr)
End Sub

zx6091024

huanghai22 发表于 2024-1-16 17:39
2010版本表示参与一下

大哥，这个方式貌似颜色没了，我转换为一列，是因为我还要对数据再加工一下，没有颜色的话，就不太方便进一步处理了。。

无关岁月

人员名单.7z (16.87 KB, 下载次数: 4)

2024-1-16 17:58 上传

点击文件名下载附件

zx6091024

各位大佬，因为我最终需要这样的结果，所以转为一列的话，有的文本我需要颜色和背景色才好进一步的处理，这个是我最终要的结果

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, iRow, i&, j&, rng As Range
   
    Application.ScreenUpdating = False
   
    Columns("K").Clear
    br = Array(1, 3, 5, 7, 2, 4, 6)
    With [A1].CurrentRegion
        ar = .Resize(.Rows.Count + 1)
        For j = 0 To UBound(br)
            Set rng = Range(.Cells(1, br(j)), .Cells(UBound(ar), br(j)).End(xlUp))
            iRow = Cells(Rows.Count, "K").End(xlUp).Row
            iRow = IIf(iRow = 1, 1, iRow + 1)
            rng.Copy Cells(iRow, "K")
        Next j
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

zx6091024 发表于 2024-1-16 17:56
大哥，这个方式貌似颜色没了，我转换为一列，是因为我还要对数据再加工一下，没有颜色的话，就不太方便进 ...

请参考。。。