Цитирование через рабочие листы

Question

Я начинаю с VBA (начал 3 дня назад), пытаясь построить макрос. Я надеюсь получить помощь с моим кодом, а также понять, что происходит с кодом в тех частях, в которых я ошибся.

Целью кода является сбор значений из ячеек в последнем столбце каждого листа и их компиляция в столбце банка на первом листе (который я создам при первом открытии рабочего листа).

Мой код очень сырой и, возможно, содержит много ошибок. Это, для большинства частей, скопировано и вставлено из источников (даже из макрорекордера). Мне удалось заставить его работать, но я надеюсь его конденсировать. Код, который работает:

Sub Test() 
    Dim LastCol As Long 
    Dim rng As Range 

    ' Creating a bank sheet 
    Sheets.Add 

    ' Returning to Page 1 
    Sheets("Page 1").Activate 

    ' Use all cells on the sheet "Page 1" 
    Set rng = Sheets("Page 1").Cells 

    ' Find the last column in "Page 1" and COPY 
    LastCol = Last(2, rng) 
    rng(2, LastCol).Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Selection.Copy 

    ' Paste Selection in Sheet1 
    Sheets("Sheet1").Activate 
    Sheets("Sheet1").Paste 

    ' Reset cursor to next blank space 
    Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select 

    ' Repeat for Page 2 
    Sheets("Page 2").Activate 
    Set rng = Sheets("Page 2").Cells 
    LastCol = Last(2, rng) 
    rng(2, LastCol).Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Selection.Copy 
    Sheets("Sheet1").Activate 
    Sheets("Sheet1").Paste 

    ' Reset cursor to next blank space 
    Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select 

    ' Repeat for Page 3 
    Sheets("Page 3").Activate 
    Set rng = Sheets("Page 3").Cells 
    LastCol = Last(2, rng) 
    rng(2, LastCol).Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Selection.Copy 
    Sheets("Sheet1").Activate 
    Sheets("Sheet1").Paste 

    ' Selecting range to sort 
    Set rng = ActiveSheet.Cells 
    LastCell = Last(3, rng) 
    With rng.Parent 
     .Select 
     .Range("A1", LastCell).Select 
    End With 

    ' Sorting 
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear 
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A177"), _ 
     SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 
    With ActiveWorkbook.Worksheets("Sheet1").Sort 
     .SetRange Range("A2:A176") 
     .Header = xlNo 
     .MatchCase = False 
     .Orientation = xlTopToBottom 
     .SortMethod = xlPinYin 
     .Apply 
    End With 
End Sub 

Это не будет работать для книг с различным количеством рабочих листов. Я попытался сконденсировать его, найдя количество рабочих листов и прокручивая их, но я не могу больше понять из онлайн-источников. Это то, что я постарался сделать:

For N = 2 To ThisWorkbook.Worksheets.Count 

    ' Use all cells on active sheet 
    ActiveWorkbook.Worksheets(N).Select 
    Set rng = ActiveWorkbook.Cells 

    ' Find the last column in active sheet and COPY 
    LastCol = Last(2, rng) 
    rng(2, LastCol).Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Selection.Copy 

    ' Paste Selection in Sheet1 
    Sheets("Sheet1").Activate 
    Sheets("Sheet1").Paste 

    ' Reset cursor to next blank space 
    Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select 

    Next N 

К сожалению, этот код не работает.

Как создать цикл для достижения того, что я смог сделать с моим первым кодом?

Соответствующие функции я использовал в моем коде, приведены ниже (любезность от Ron De Bruin):

Function Last(choice As Long, rng As Range) 
'Ron de Bruin, 5 May 2008 
' 1 = last row 
' 2 = last column 
' 3 = last cell 
Dim lrw As Long 
Dim lcol As Long 

Select Case choice 

Case 1: 
    On Error Resume Next 
    Last = rng.Find(What:="*", _ 
        After:=rng.Cells(1), _ 
        Lookat:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByRows, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Row 
    On Error GoTo 0 

Case 2: 
    On Error Resume Next 
    Last = rng.Find(What:="*", _ 
        After:=rng.Cells(1), _ 
        Lookat:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByColumns, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Column 
    On Error GoTo 0 

Case 3: 
    On Error Resume Next 
    lrw = rng.Find(What:="*", _ 
        After:=rng.Cells(1), _ 
        Lookat:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByRows, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Row 
    On Error GoTo 0 

    On Error Resume Next 
    lcol = rng.Find(What:="*", _ 
        After:=rng.Cells(1), _ 
        Lookat:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByColumns, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Column 
    On Error GoTo 0 

    On Error Resume Next 
    Last = rng.Parent.Cells(lrw, lcol).Address(False, False) 
    If Err.Number > 0 Then 
     Last = rng.Cells(1).Address(False, False) 
     Err.Clear 
    End If 
    On Error GoTo 0 

End Select 
End Function 

Function LastCol(sh As Worksheet) 
On Error Resume Next 
LastCol = sh.Cells.Find(What:="*", _ 
         After:=sh.Range("A1"), _ 
         Lookat:=xlPart, _ 
         LookIn:=xlFormulas, _ 
         SearchOrder:=xlByColumns, _ 
         SearchDirection:=xlPrevious, _ 
         MatchCase:=False).Column 
On Error GoTo 0 
End Function 

Answer 1

Это, мы надеемся, вы начали. Во-первых, вот тот же код, который должен делать то же самое, насколько я могу судить. Он копирует последнюю строку вашего «Паж» рабочие листы после удаления всех выбирает и активирует:

Sub Test() 
    Dim LastCol As Long 
    Dim LastRow As Long 
    Dim NextRowDestination As Long 
    Dim rng As Range 

    Sheets.Add After:=Worksheets(Worksheets.Count) 
    Worksheets(Worksheets.Count).Name = "Sheet1" 

    With Sheets("Page 1") 
     LastCol = Last(2, .Cells) 
     LastRow = Last(1, .Cells(1, LastCol).EntireColumn) 

     Set rng = Range(.Cells(2, LastCol), .Cells(LastRow, LastCol)) 
     rng.Copy Sheets("Sheet1").Cells(2, 1) 
     NextRowDestination = Last(1, Sheets("Sheet1").Cells(1, 1).EntireColumn) + 1 
    End With 

    With Sheets("Page 2") 
     LastCol = Last(2, .Cells) 
     LastRow = Last(1, .Cells(1, LastCol).EntireColumn) 

     Set rng = Range(.Cells(2, LastCol), .Cells(LastRow, LastCol)) 

     rng.Copy Sheets("Sheet1").Cells(NextRowDestination, 1) 
     NextRowDestination = Last(1, Sheets("Sheet1").Cells(1, 1).EntireColumn) + 1 
    End With 

    With Sheets("Page 3") 
     LastCol = Last(2, .Cells) 
     LastRow = Last(1, .Cells(1, LastCol).EntireColumn) 

     Set rng = Range(.Cells(2, LastCol), .Cells(LastRow, LastCol)) 

     rng.Copy Sheets("Sheet1").Cells(NextRowDestination, 1) 
     NextRowDestination = Last(1, Sheets("Sheet1").Cells(1, 1).EntireColumn) + 1 
    End With 

End Sub 

Как вы можете видеть, это легко сказать, что происходит на каждый лист. Кроме того, вы быстро заметите, что у вас много дублирующихся кодов! Идеальное место для цикла (И вы можете задать свой главный вопрос: «Что, если у меня есть более 3 листов?» Ответил бесплатно)!

Sub Test2() 
    Dim LastCol As Long 
    Dim LastRow As Long 
    Dim counter As Long 
    Dim NextRowDestination As Long 

    Dim rng As Range 

    Dim ws As Worksheet 

    Sheets.Add After:=Worksheets(Worksheets.Count) 
    Worksheets(Worksheets.Count).Name = "Sheet1" 

    NextRowDestination = 2 

    For counter = 1 To ActiveWorkbook.Worksheets.Count 
     If Left(Worksheets(counter).Name, 4) = "Page" Then 

      Set ws = Worksheets(counter) 

      With ws 
       LastCol = Last(2, .Cells) 
       LastRow = Last(1, .Cells(1, LastCol).EntireColumn) 

       Set rng = Range(.Cells(2, LastCol), .Cells(LastRow, LastCol)) 

       rng.Copy Sheets("Sheet1").Cells(NextRowDestination, 1) 
       NextRowDestination = Last(1, Sheets("Sheet1").Cells(1, 1).EntireColumn) + 1 
      End With 
     End If 
    Next counter 

End Sub 

Теперь имейте в виду, я сделал несколько предположений, не видя вашу структуру данных, это было трудно для меня, чтобы представить себе: 1) Вы не хотите, чтобы скопировать любой заголовок строки 2) лист, который вы создаете, не имеет строки заголовка, и данные начинают копироваться в строке 2. 3) Я ничего не сделал с вашим кодом сортировки, так как я не был полностью уверен, что вы там делали ,
4) Я не собирался проверять дубликат Sheet1 или что-то в этом роде. Обработка ошибок должна приниматься во внимание.

Но приведенный выше код Test2 должен быть очень близок к тому, что вы пытаетесь сделать (минус бит сортировки).

Answer 2

Может быть, это поможет:

Option Explicit 

Public Sub makeBank() 
    Dim bnk As Worksheet, lrBnk As Long, ur As Range, rngBnk As Range 
    Dim ws As Worksheet, fr As Long, lr As Long, lc As Long, rngThis As Range 

    enableXl False          'disable screen and alerts 
    With Application.ActiveWorkbook 
     For Each ws In .Worksheets      'go through all sheets 
      If ws.Name = "Bank" Then ws.Delete: Exit For 'and remove bnk sheet if exists 
     Next 
     .Worksheets.Add Before:=.Worksheets(1)   'add new sheet before all others 
     Set bnk = .Worksheets(1)      'set a reference to the new sheet 
     bnk.Name = "Bank"        'rename it 

     For Each ws In .Worksheets 
      If ws.Name <> "Bank" Then     'exclude bnk sheet 
       fr = ws.UsedRange.Row     'first used row on current sheet 
       lr = ws.UsedRange.Rows.Count   'last used row on current sheet 
       lc = ws.UsedRange.Columns.Count   'last used col on current sheet 

       Set ur = bnk.UsedRange     'used range on bnk 
       lrBnk = ur.Row + ur.Rows.Count   'last used row on bnk 

       Set rngBnk = bnk.Range(bnk.Cells(lrBnk, 1), bnk.Cells(lrBnk + lr - 1, 1)) 
       Set rngThis = ws.Range(ws.Cells(fr, lc), ws.Cells(lr, lc)) 

       rngBnk.Value2 = rngThis.Value2   'append this last col to bnk's 1st 
      End If 
     Next 
     bnk.Rows(1).EntireRow.Delete     'delete first (extra) row on bnk 
     sortCol bnk.UsedRange.Columns(1)    'sort first column on bnk sheet 
    End With 
    enableXl True          'enable screen and alerts 
End Sub 

---

Другие функции используются:

Private Sub sortCol(ByVal col As Range) 
    With col.Parent.Sort 
     .SortFields.Clear 
     .SortFields.Add Key:=col, Order:=xlAscending 
     .SetRange col 
     .Header = xlNo 
     .MatchCase = False 
     .Orientation = xlTopToBottom 
     .Apply 
    End With 
End Sub 

Private Sub enableXl(ByVal opt As Boolean) 
    With Application 
     .ScreenUpdating = opt 
     .DisplayAlerts = opt 
    End With 
End Sub 

---

Как основные Суб работы (makeBank)

• Если рабочий лист с именем «Банк» существует, то он удаляет его
• Создает новый «Банк» лист

• проходит через все листы, кроме «Банка», и

  • определяет первый используется ряд, последний используется ряд, и последний использованный колонок на текущем листе
  • определяет первую пустую строку на «Банке» (плюс смещение по строкам скопированных)
  • копии последний используемой столбца на текущем листе и присоединяют его к первой пустой строке на банке
  • переходит к следующий лист

• В первой итерации он генерирует пустую строку на банке, так что в конце она удаляет его

• виды колонке данных о банке