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

Question

У меня есть рабочая книга, которая содержит 300 листов Jan1990, Feb1990, .... Dec2016.

Каждый лист содержит данные в столбце A1: AS11, и я хочу только данные столбца AR (11 строк в каждом столбце) из всех 300 листов в листе, названном «Мастера».

Я нашел один код на форуме, но мне нужно снова и снова менять имя листа, чтобы получить данные в приведенном ниже коде. Также в столбце AR содержится формула, поэтому мне нужно только значение, а не формула.

Sub Demo()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim path As String, fileName As String
Dim lastRowInput As Long, lastRowOutput As Long, rowCntr As Long, lastColumn As Long
Dim inputWS As Worksheet, outputWS As Worksheet

'set your sheets here
Set inputWS = ThisWorkbook.Sheets("SEP2014")
Set outputWS = ThisWorkbook.Sheets("Master")
rowCntr = 1

'get last rows from both sheets
lastRowInput = inputWS.Cells(Rows.Count, "A").End(xlUp).Row
lastRowOutput = outputWS.Cells(Rows.Count, "A").End(xlUp).Row
lastColumn = inputWS.Cells(1, Columns.Count).End(xlToLeft).Column

'copy data from columns AR, AS
inputWS.Range("AR1:AR11" & lastRowInput).Copy outputWS.Range("F" & lastRowOutput + 1)


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Я новичок в VBA, поэтому любая помощь будет принята. С уважением, Харис

Answer 1

Отредактировал ваш код. Как предлагает BigBen, он содержит все oop для копирования столбцов AR со всех листов, кроме Master. Он вставляется ниже предыдущего в столбце F мастер-листа в соответствии с вашим кодом. Вы также можете вставить их рядом. Предполагая, что основным листом является Лист (1), l oop начинается с i = 2, т.е. Лист (2)

Sub Demo()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim path As String, fileName As String
Dim lastRowInput As Long, lastRowOutput As Long, rowCntr As Long, lastColumn As Long
Dim inputWS As Worksheet, outputWS As Worksheet

'set your sheets here
'Set inputWS = ThisWorkbook.Sheets("SEP2014")
Set outputWS = ThisWorkbook.Sheets("Master")
rowCntr = 1

For i = 2 To ThisWorkbook.Sheets.Count
If ThisWorkbook.Sheets(i).Name <> "Master" Then
Set inputWS = ThisWorkbook.Sheets(i)

'get last rows from both sheets
lastRowInput = inputWS.Cells(Rows.Count, "A").End(xlUp).Row
'lastRowOutput = outputWS.Cells(Rows.Count, "A").End(xlUp).Row
lastRowOutput = outputWS.Cells(Rows.Count, "F").End(xlUp).Row
lastColumn = inputWS.Cells(1, Columns.Count).End(xlToLeft).Column

'copy data from columns AR, AS
'inputWS.Range("AR1:AR11" & lastRowInput).Copy outputWS.Range("F" & lastRowOutput + 1)

' to paste them one below the prevous.
inputWS.Range("AR1:AR" & lastRowInput).Copy outputWS.Range("F" & lastRowOutput + 1)


' to paste them side by side from F column.
'inputWS.Range("AR1:AR" & lastRowInput).Copy outputWS.Cells(1, 4 + i)

End If

Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Answer 2

Требуется лишь небольшое изменение, передайте имя листа в свою подпункт, затем в другой подпункт l oop в списке имен листов:

Sub LoopOnSheets()

dim sheetNames() as string
dim x as integer

sheetNames = split("sheet name one,sheet name two,and so on",",") ' list your sheets here separated by a comma

for x = 0 to ubound(sheetNames) - 1
   Demo Sheets(sheetNames(x)) ' this will pass the sheet to your Demo sub to work on
next x

End Sub

Sub Demo(inputWS As Worksheet)

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim path As String, fileName As String
Dim lastRowInput As Long, lastRowOutput As Long, rowCntr As Long, lastColumn As Long
Dim outputWS As Worksheet

'set your sheets here
Set outputWS = ThisWorkbook.Sheets("Master")
rowCntr = 1

'get last rows from both sheets
lastRowInput = inputWS.Cells(Rows.Count, "A").End(xlUp).Row
lastRowOutput = outputWS.Cells(Rows.Count, "A").End(xlUp).Row
lastColumn = inputWS.Cells(1, Columns.Count).End(xlToLeft).Column

'copy data from columns AR, AS
inputWS.Range("AR1:AR11" & lastRowInput).Copy outputWS.Range("F" & lastRowOutput + 1)

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub