Question

我需要能够将每3列转换为1列，同时还选择三列并根据标题名称从左到右排序。

原始

CBAFEDIGH

输出

ADG

BEH

CFI

我有以下代码允许我能够转换为一列，但它不会将其限制为三列并重复每三列。我仍在试图找出i =和第3步

我知道在处理3列时可以通过脚本设置排序。只需要一点帮助就可以了。

选项明确

Sub COLMERGE()
    Dim lr As Long
    Dim lrX As Long
    lrX = Range("A" & Rows.Count).End(xlUp).Row
    Dim i As Long
    Dim lc As Long
    lc = Cells(1, Columns.Count).End(xlToLeft).Column

    Application.ScreenUpdating = False
    For i = 2 To lc
    lr = Range("A" & Rows.Count).End(xlUp).Row
    Range(Cells(2, i), Cells(lrX, i)).Cut Range("A" & lr + 1)
    Next i
    Range(Cells(1, 2), Cells(1, lc)).ClearContents
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

Answer 1

我能够使用以下代码

正确处理列

Option Explicit

Sub ColMerge()
    Dim lr As Long
    Dim lrX As Long
    lrX = Range("A" & Rows.Count).End(xlUp).Row
    Dim i As Long
    Dim j As Long
    Dim lc As Long
    Dim ws As Worksheet
    lc = Cells(1, Columns.Count).End(xlToLeft).Column

    Application.ScreenUpdating = False
    For i = 2 To lc Step 3

    Range(Cells(2, i), Cells(31, i)).Cut Range(Cells(32, i - 1), Cells(61, i - 1))
    Range(Cells(2, i + 1), Cells(31, i + 1)).Cut Range(Cells(62, i - 1), Cells(91, i - 1))

    Next i

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox ("Completed")

End Sub

我可以使用以下代码进行排序：

Option Explicit

Sub ReSort_LtoR()
    Dim lr As Long
    Dim lrX As Long
    lrX = Range("A" & Rows.Count).End(xlUp).Row
    Dim i As Long
    Dim j As Long
    Dim lc As Long
    Dim ws As Worksheet
    lc = Cells(1, Columns.Count).End(xlToLeft).Column

    Application.ScreenUpdating = False
    For i = 1 To lc Step 3

    Range(Cells(1, i), Cells(31, i + 2)).Select
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range(Cells(1, i), Cells(1, i + 2)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range(Cells(1, i), Cells(31, i + 2))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With

    Next i

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox ("Completed")

End Sub

复制A列下的B列和C列，每3列重复一次

1 个答案: