VBA: Скопируйте столбцы E, F и G, вставьте данные под данными в B, C, D. Повторите для каждых 3 столбцов

Question

Я хочу переместить сто или около того столбцов на одном листе в первые 3 столбца на одном листе. Я хотел бы взять столбцы в E, F, G, вставить их под данными в B, C, D, а затем взять столбцы H, I, J и вставить их в нижней части B, C, D (который теперь включает в себяданные из E, F, G. повторяют эту процедуру для каждых 3 столбцов до конца данных. Любая помощь будет оценена. Спасибо.

Sub OneColumnV2() 

Dim iLastcol As Long
Dim iLastRow As Long
Dim jLastrow As Long
Dim ColNdx As Long
Dim ws As Worksheet
Dim myRng As Range
Dim ExcludeBlanks As Boolean
Dim mycell As Range

ExcludeBlanks = (MsgBox("Exclude Blanks", vbYesNo) = vbYes)
Set ws = ActiveSheet
iLastcol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
On Error Resume Next

Application.DisplayAlerts = False
Worksheets("Alldata").Delete
Application.DisplayAlerts = True

Sheets.Add.Name = "Alldata"

For ColNdx = 1 To iLastcol

  iLastRow = ws.Cells(ws.Rows.Count, ColNdx).End(xlUp).Row

  Set myRng = ws.Range(ws.Cells(1, ColNdx), _
                       ws.Cells(iLastRow, ColNdx))

  If ExcludeBlanks Then
     For Each mycell In myRng
        If mycell.Value <> "" Then
           jLastrow = Sheets("Alldata").Cells(Rows.Count, 1) _
                      .End(xlUp).Row
           mycell.Copy
           Sheets("Alldata").Cells(jLastrow + 1, 1) _
              .PasteSpecial xlPasteValues
        End If
     Next mycell
  Else
     myRng.Copy
     jLastrow = Sheets("Alldata").Cells(Rows.Count, 1) _
                .End(xlUp).Row
     mycell.Copy
     Sheets("Alldata").Cells(jLastrow + 1, 1) _
        .PasteSpecial xlPasteValues
  End If
Next

Sheets("Alldata").Rows("1:1").EntireRow.Delete

ws.Activate
End Sub

Я считаю, что проблема возникает в определении«iLastcol» вместо xlToLeft, диапазон столбцов должен охватывать 3 столбца там.

Answer 1

Ваш код немного сбивает с толку, поэтому я написал это на основе того, что вы задали в своем вопросе. Это должно делать то, что вы хотите. Только примечание об исключении пустых ячеек, оно изменит выравнивание каждых трех ячеек столбцов друг с другом при копировании. Я не уверен, что это задумано или упущение. Так что я не включил это в приведенный ниже код, но вы можете легко включить его, если хотите

    Sub moveColumnsData()

    Dim sourceLastRow As Long
    Dim destLastRow As Long
    Dim lastColumn As Long
    Dim i As Long
    Dim sourceRng As Range
    Dim destRng As Range
    Dim a As Range

    With ActiveSheet
        lastColumn = .UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column

        'loop through every set of 3 columns
        For i = 5 To lastColumn Step 3
            sourceLastRow = .Range(.Columns(i), .Columns(i + 2)).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

            'incase columns BCD are blank then set last row=1
            Set a = .Columns("B:D").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious)
            If Not a Is Nothing Then
                destLastRow = a.Row + 1
            Else
                destLastRow = 1
            End If

            'no need to use copy/paste, just let the range equals to each other
            Set sourceRng = .Range(.Cells(1, i), .Cells(sourceLastRow, i + 2))
            .Cells(destLastRow, "B").Resize(sourceRng.Rows.Count, sourceRng.Columns.Count) = sourceRng.value

        Next

        'uncomment below to clear all columns besides BCD
        '.Range(.Columns("E"), .Columns(lastColumn)).Clear
    End With

    End Sub

Answer 2

Привет, не чистое решение, но вполне функциональное и работает как шарм! CopyAdjDataUnderMyTable()

Каждый раз, когда вы запускаете эту функцию, вы копируете 3 соседних столбца (EFG) и перемещаете ее ниже BCD, как в примере.

Sub CopyAdjDataUnderMyTable()

    Range("B1").Select
    ActiveCell.Offset(0, 3).Select
    Range(Selection, Selection.Offset(0, 2)).Select

    'MsgBox (Range(Selection, Selection.End(xlDown)).Cells.SpecialCells(xlCellTypeConstants).Count)

        If Range(Selection, Selection.End(xlDown)).Cells.SpecialCells(xlCellTypeConstants).Count = 3 Then
        Range(Selection, Selection.Offset(1, 0)).Select
        Else
        Range(Selection, Selection.End(xlDown)).Select
        End If

    Selection.Cut
    Range("B1").Select

      'MsgBox (Range(Selection, Selection.End(xlDown)).Cells.SpecialCells(xlCellTypeConstants).Count)

        If Range(Selection, Selection.End(xlDown)).Cells.SpecialCells(xlCellTypeConstants).Count = 1 Then
        Selection.Offset(0, 0).Select
        Else
        Selection.End(xlDown).Select
        End If


    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Range("B1").Select

   ActiveCell.Offset(0, 3).Select
   Range(Selection, Selection.Offset(0, 2)).Select
   Range(Selection, Selection.End(xlDown)).Select
   Selection.Delete Shift:=xlToLeft

   Range("B1").Select


End Sub