Копирование указанных c столбцов с нескольких листов после активного листа VBA

Question

Я пытаюсь кодировать VBA, который выбирает первый столбец каждого листа после активного листа, на котором я работаю (это изменится), и копирует во вновь созданный лист, который появится после активного листа

Этот код не будет работать, но, надеюсь, он даст представление о том, чего я пытаюсь достичь

Dim sht As ActiveSheet

Sheets(after.sht).Columns("1").copy 'I want to copy column one from every sheet after the current sheet I'm on
Sheets.Add after:=sht.paste 'then paste into a new sheet which appears after the Active sheet I started on

Answer 1

Попробуйте:

Dim flagSh    As Worksheet
Dim newSh     As Worksheet
Dim i         As Long

With ThisWorkbook
  If ActiveSheet.Index = .Worksheets.Count Then Exit Sub
  Set flagSh = ActiveSheet
  .Worksheets.Add , flagSh
  Set newSh = ActiveSheet

  For i = .Worksheets.Count To newSh.Index + 1 Step -1
    .Worksheets(i).Columns(1).Copy
    newSh.Columns(1).Insert Shift:=xlToRight
  Next
  Application.CutCopyMode = False
End With

Надеюсь, это поможет вам начать работу.

Answer 2

Option Explicit
Sub CopyColumns()

Dim Source As Worksheet
Dim Destination As Worksheet
Dim Last As Long

Application.ScreenUpdating = False

'Checking whether "Master" sheet already exists in the workbook
For Each Source In ThisWorkbook.Worksheets
    If Source.Name = "Master" Then
        MsgBox "Master sheet already exist"
        Exit Sub
    End If
Next

'Inserting new worksheets in the workbook
Set Destination = Worksheets.Add(after:=Worksheets("Main"))

'Renaming the worksheet
Destination.Name = "Master"

'Looping through the worksheets in the workbook
For Each Source In ThisWorkbook.Worksheets


    If Source.Name <> "Master" And Source.Name <> "Main" Then

        'Finding the last column from the destination sheet
        Last = Destination.Range("A1").SpecialCells(xlCellTypeLastCell).Column

        If Last = 1 Then
            'Pasting the data in the destination sheet
            Source.UsedRange.Copy Destination.Columns(Last)
        Else
            Source.UsedRange.Copy Destination.Columns(Last + 1)
        End If
    End If
Next

Columns.AutoFit

Application.ScreenUpdating = True

End Sub