Перебирайте листы и создавайте таблицы

Question

У меня есть 10 листов.

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

Я бы очень признателен за помощь:)

Sub table()
    Dim sht As Worksheet
    Dim lastrow As Long
    Dim LastColumn As Long
    Dim StartCell As Range

    Set sht = Worksheets("m9")
    Set StartCell = Range("A1")

    lastrow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
    LastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column

    sht.Range(StartCell, sht.Cells(lastrow, LastColumn)).Select

    Dim objTable As ListObject
    Set objTable = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
End Sub

попробовал следующее, но без удачи

    Sub loop_test()

Dim i As Integer
Dim ws_num As Integer

Dim starting_ws As Worksheet
Set starting_ws = ActiveSheet
ws_num = ThisWorkbook.Worksheets.Count

For i = 1 To ws_num
    ThisWorkbook.Worksheets(i).Activate
    '
    Dim lastrow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set StartCell = Range("A1")


  lastrow = Cells(Rows.Count, StartCell.Column).End(xlUp).Row
  Range(StartCell, Cells(lastrow, LastColumn)).Select

  Dim objTable As ListObject
Set objTable = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)



Next

starting_ws.Activate
End Sub

Answer 1

Вам следует избегать Activate и Select заявлений.Далее будут циклически проходить все листы в книге и добавляться ListObject к каждому листу.Он также проверит, существует ли уже существующий ListObject.Если существующий ListObject перекрывается с диапазоном, в который вы собираетесь добавить таблицу, он преобразует его в диапазон до воссоздания ListObject

Sub loop_test()
    Dim ws As Worksheet
    Dim StartCell As Range, TblRng As Range
    Dim LastRow As Long, LastColumn As Long
    Dim objTable As ListObject

    For Each ws In ThisWorkbook.Sheets
        Set objTable = Nothing
        With ws
            Set StartCell = .Range("A1")
            LastRow = .Cells(.Rows.Count, StartCell.Column).End(xlUp).Row
            LastColumn = .Cells(StartCell.Row, .Columns.Count).End(xlToLeft).Column


            Set TblRng = .Range(StartCell, .Cells(LastRow, LastColumn))
            ' Test if table exists on sheet
            On Error Resume Next
            Set objTable = .ListObjects(1)
            On Error GoTo 0
            ' If table overlaps with TblRng - Convert to Range
            If Not Intersect(objTable.Range, TblRng) Is Nothing Then
                objTable.Unlist
            End If
            ' Create Table
            Set objTable = .ListObjects.Add(xlSrcRange, TblRng, , xlYes)
        End With
    Next ws
End Sub

Answer 2

Попробуй это.Как говорит Зак, держитесь подальше от активации и выбора и включайте ссылки на листы.

Sub loop_test()

Dim i As Long 'use Long, integer only goes up to c32k
Dim ws_num As Long

Dim starting_ws As Worksheet
Set starting_ws = ActiveSheet

ws_num = ThisWorkbook.Worksheets.Count
Dim lastrow As Long
Dim LastColumn As Long
Dim StartCell As Range, r As Range
Dim objTable As ListObject

For i = 1 To ws_num
    With ThisWorkbook.Worksheets(i) 'don't need to activate
        Set StartCell = .Range("A1")
        lastrow = .Cells(.Rows.Count, StartCell.Column).End(xlUp).Row
        Set r = .Range(StartCell, .Cells(lastrow, LastColumn))
        Set objTable = .ListObjects.Add(xlSrcRange, r, , xlYes)
    End With
Next i

End Sub