Problems with tables

[seryf]

Hello guys, I need to edit this code.
My needs: I need to save tables when i call the sub. I have 4 different groups of tables which are sorted by checkboxes. When I mark checkbox1 i want to save table on line 1-5, checkbox2 line 7-11, etc... this is already setted
But i cant add the formula to move old tables to the right when i add the new one.
The tables are week reports of our data and i need every when I start the whole vba code to move old tables to right and put the newest one on the start of the sheet
Also i would like to add rule to not do enything if i have already created the table with similiar week and checkbox because i dont want to rewrite it or to make duplicates.
Also I would like to line up the tables given the time , so if i have already created table from week 28 and 30 and now i am going to create week 29, i would like to have the table between these two.
I consider that as pretty difficult because of the checkboxes. There are different weeks but also different checkboxes, so acceptable combinations can be for example week 1, checkbox1 marked, week 1,checkbox3 marked, but not again week1,checkbox1 marked again.

Can you please help me out?

Thanks you all in advance

Code:

Sub Souhrn()
Application.ScreenUpdating = False

Dim wsPrehled As Worksheet
Dim ovladacSheet As Worksheet
Dim weekNumber As Long
Dim dataRangeIN As Range, dataRangeOUT As Range
Dim CheckBox1 As Boolean, CheckBox2 As Boolean, CheckBox3 As Boolean, CheckBox4 As Boolean
Dim lastTable As ListObject
Dim newTable As ListObject
Dim nextRow As Long
Dim selectedRowOffset As Long
Dim lastRow As Long
Dim existingWeeks As Collection

' Nastavte reference na listy "Přehled" a "Ovladac"
Set wsPrehled = ThisWorkbook.Sheets("Přehled")
Set ovladacSheet = ThisWorkbook.Sheets("Ovladac")

' Zkontrolujeme, které checkboxy jsou zaškrtnuty na listu "Ovladac"
CheckBox1 = ovladacSheet.OLEObjects("Checkbox1").Object.Value
CheckBox2 = ovladacSheet.OLEObjects("Checkbox2").Object.Value
CheckBox3 = ovladacSheet.OLEObjects("Checkbox3").Object.Value
CheckBox4 = ovladacSheet.OLEObjects("Checkbox4").Object.Value

' Pokud nebyl vybrán žádný checkbox, ukončíme makro
If Not (CheckBox1 Or CheckBox2 Or CheckBox3 Or CheckBox4) Then
MsgBox "Zaškrtněte alespoň jeden checkbox na listu Ovladac.", vbExclamation
Application.ScreenUpdating = True
Exit Sub
End If

' Získáme číslo týdne z buňky S22 na listu "Ovladac"
weekNumber = ovladacSheet.Range("S22").Value

' Zkontrolujeme, zda už neexistuje tabulka s tímto týdnem a checkboxem
Dim tableAlreadyExists As Boolean
tableAlreadyExists = False

For Each Table In wsPrehled.ListObjects
If Table.HeaderRowRange.Cells(1, 1).Value = weekNumber And Table.HeaderRowRange.Cells(1, 2).Value = CheckBox1 Then
tableAlreadyExists = True
Exit For
End If
Next Table

If tableAlreadyExists Then
MsgBox "Tabulka pro tento týden a checkbox již byla dříve vytvořena.", vbExclamation
Application.ScreenUpdating = True
Exit Sub
End If

' Najdeme poslední řádek, na kterém je poslední tabulka
On Error Resume Next
Set lastTable = wsPrehled.ListObjects("Table1") ' Nahraďte "Table1" názvem tabulky na listu "Přehled"
On Error GoTo 0

If lastTable Is Nothing Then
lastRow = 1 ' Pokud žádná tabulka na listu není, začneme na prvním řádku
Else
lastRow = lastTable.HeaderRowRange.Row + lastTable.ListRows.count + 3 ' Přidáme 3 řádky mezi tabulkami (nadpisy sloupců a mezera mezi checkboxy)
End If

' Vytvoříme novou tabulku na list "Přehled" podle zvoleného checkboxu
If CheckBox1 Then
Set newTable = wsPrehled.ListObjects.Add(xlSrcRange, wsPrehled.Cells(lastRow, 1).Resize(1, 4))
selectedRowOffset = 0
ElseIf CheckBox2 Then
Set newTable = wsPrehled.ListObjects.Add(xlSrcRange, wsPrehled.Cells(lastRow + 6, 1).Resize(1, 4))
selectedRowOffset = 6
ElseIf CheckBox3 Then
Set newTable = wsPrehled.ListObjects.Add(xlSrcRange, wsPrehled.Cells(lastRow + 12, 1).Resize(1, 4))
selectedRowOffset = 12
ElseIf CheckBox4 Then
Set newTable = wsPrehled.ListObjects.Add(xlSrcRange, wsPrehled.Cells(lastRow + 18, 1).Resize(1, 4))
selectedRowOffset = 17
End If


' Zkontrolujeme, zda tabulka existuje, a pokud ne, vytvoříme ji spolu s názvy sloupců
If newTable Is Nothing Then
MsgBox "Tabulky pro třetí a čtvrtý checkbox nejsou v tomto příkladu implementovány. Dodatečně je můžete upravit podle vašich potřeb.", vbExclamation
Application.ScreenUpdating = True
Exit Sub
End If

' Nastavíme názvy sloupců tabulky
newTable.ListColumns(1).Name = "Týden"
newTable.ListColumns(2).Name = "IN"
newTable.ListColumns(3).Name = "OUT"
newTable.ListColumns(4).Name = "Celkem"

' Nastavíme rozsahy pro IN a OUT na listu "Ovladac" podle zaškrtnutých checkboxů
If CheckBox1 Then
Set dataRangeIN = ovladacSheet.Range("AB31:AB33")
Set dataRangeOUT = ovladacSheet.Range("AB35:AB37")
ElseIf CheckBox2 Then
Set dataRangeIN = ovladacSheet.Range("AB31:AB33")
Set dataRangeOUT = ovladacSheet.Range("AB35:AB37")
ElseIf CheckBox3 Then
Set dataRangeIN = ovladacSheet.Range("AB31:AB33")
Set dataRangeOUT = ovladacSheet.Range("AB35:AB37")
ElseIf CheckBox4 Then
Set dataRangeIN = ovladacSheet.Range("AB31:AB33")
Set dataRangeOUT = ovladacSheet.Range("AB35:AB37")
End If

' Naplníme tabulku daty a nastavíme číslo týdne pro každý řádek
For i = 1 To 3 ' Předpokládáme, že budou vždy tři řádky s daty IN a OUT
newTable.ListRows.Add
newTable.ListRows(newTable.ListRows.count).Range(1) = weekNumber
newTable.ListRows(newTable.ListRows.count).Range(2) = dataRangeIN.Cells(i, 1).Value
newTable.ListRows(newTable.ListRows.count).Range(3) = dataRangeOUT.Cells(i, 1).Value
Next i

' Přidáme celkový řádek s rozdílem pro IN a OUT pouze v posledním řádku tabulky
newTable.ListRows.Add
newTable.ListRows(newTable.ListRows.count).Range(1) = "Celkem"
newTable.ListRows(newTable.ListRows.count).Range(2).Formula = "=SUM(B" & 2 + selectedRowOffset & ":B" & 4 + selectedRowOffset & ")"
newTable.ListRows(newTable.ListRows.count).Range(3).Formula = "=SUM(C" & 2 + selectedRowOffset & ":C" & 4 + selectedRowOffset & ")"
newTable.ListRows(newTable.ListRows.count).Range(4) = newTable.ListRows(newTable.ListRows.count).Range(2) - newTable.ListRows(newTable.ListRows.count).Range(3)


Application.ScreenUpdating = True
End Sub

 

[seryf]

common error - cant push objects off the sheet, application defined error