Копирование данных из каждого 4-го столбца в Excel

Question

У меня есть необработанные данные со 100+ столбцами на листе 1, и мне нужно скопировать каждый 4-й столбец на листе 2. Я попробовал ссылку на ячейку, просто хотел узнать, есть ли в Excel какая-либо формула для выполнения этого действия.

Снимок экрана листа 1 и листа 2 для справки.

Любойпомощь в этом отношении очень ценится.

Answer 1

Это динамично как по строкам, так и по столбцам.

Предполагается, что Column A на обоих листах является хорошим индикатором того, где можно найти последнюю строку.

---

Sub Columns()

Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")

Dim LR As Long, LC As Long, LR2 As Long, Counter As Long, CopyRange As Range

LR = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
LC = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
LR2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Offset(1).Row
Counter = 1

Application.ScreenUpdating = False
    For i = 1 To LC Step 3
        ws1.Range(ws1.Cells(2, i), ws1.Cells(LR, i)).Copy
        ws2.Cells(LR2, Counter).PasteSpecial xlPasteValues
        Counter = Counter + 1
    Next i
Application.ScreenUpdating = True

End Sub

Answer 2

Вы можете сделать это с формулой, ее базовая форма - =OFFSET($C$5,0,(COLUMN(A8)*n)-1), но это означает, что вам придется копировать ее настолько, насколько требуется, чтобы охватить весь диапазон.Более постоянное решение - использовать VBA.

Answer 3

Попробуйте:

Option Explicit

Sub test()

    Dim LR As Long
    Dim LC As Long
    Dim LC2 As Long
    Dim i As Long

    With Worksheets("Sheet1")

        LC = .Cells(1, .Columns.Count).End(xlToLeft).Column

        For i = 1 To LC Step 3
            LR = .Cells(Rows.Count, i).End(xlUp).Row
            LC2 = Sheet2.Cells(1, Sheet2.Columns.Count).End(xlToLeft).Column

            If LC2 = 1 And Sheet2.Range("A1").Value = "" Then
                .Range(.Cells(1, i), .Cells(LR, i)).Copy
                    Sheet2.Cells(1, LC2).PasteSpecial Paste:=xlPasteFormulas
            Else: .Range(.Cells(1, i), .Cells(LR, i)).Copy
                    Sheet2.Cells(1, LC2 + 1).PasteSpecial Paste:=xlPasteFormulas
            End If
        Next i

    End With

End Sub

Answer 4

Возможно проверить смещение. Работает для строк и столбцов https://exceljet.net/formula/copy-value-from-every-nth-column