Sub CollectDataFromAllSheets()
    Dim ws As Worksheet
     
    Set wbCurrent = ActiveWorkbook
    Workbooks.Add
    Set wbReport = ActiveWorkbook
     
    'копируем на итоговый лист шапку таблицы из первого листа
    wbCurrent.Worksheets(1).Range("A1:D1").Copy Destination:=wbReport.Worksheets(1).Range("A1")
     
    'проходим в цикле по всем листам исходного файла
    For Each ws In wbCurrent.Worksheets
     
        'определяем номер последней строки на текущем листе и на листе сборки
        n = wbReport.Worksheets(1).Range("A1").CurrentRegion.Rows.Count
         
        'задаем исходный диапазон, который надо скопировать с каждого листа - любой вариант на выбор:
        Set rngData = ws.Range("A1:D5")            'фиксированный диапазон или
        Set rngData = ws.UsedRange                 'всё, что есть на листе или
        Set rngData = ws.Range("F5").CurrentRegion    'область, начиная от ячейки F5 или
        Set rngData = ws.Range("A2", ws.Range("A2").SpecialCells(xlCellTypeLastCell))    'от А2 и до конца листа
         
        'копируем исходный диапазон и вставляем в итоговую книгу со следующей строки
        rngData.Copy Destination:=wbReport.Worksheets(1).Cells(n + 1, 1)
         
    Next ws
End Sub

Private Sub UserForm_Initialize()
    Dim li As Long
    With ThisWorkbook.Sheets("Users")
        For li = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
            cmbUsers.AddItem .Cells(li, 1)
        Next li
    End With
    bClose = True
End Sub

cmbUsers.AddItem .Cells(li, 1)

Sub Main()
    frmIndicateUser.Show
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim i As Long
Dim lc&, lr&
ThisWorkbook.Worksheets("Sheet1").Activate
With Application
        .ScreenUpdating = False   
        .Calculation = xlManual     
For lc = 1 To Cells(1, Columns.Count).End(xlToLeft).Column       
For lr = 2 To Cells(Rows.Count, lc).End(xlUp).Row                
  If Cells(lr, lc).Value <> 0 Then
     Cells(lr, lc).Value = Cells(lr, lc).Value
  End If
Next lr
Next lc
.Calculation = xlAutomatic  
        .ScreenUpdating = True     
End With
End Sub

ThisWorkbook.Worksheets("Serfiyyat 2").Activate
With Application
        .ScreenUpdating = False   'отключаем обновление экрана
        .Calculation = xlManual     'отключаем автоматический пересчет формул
For i = 6 To Cells(Rows.Count, 10).End(xlUp).Row
 If Cells(i, 10).Value <> "" Then
    Cells(i, 10).Value = Cells(i, 10).Value
 End If
Next i
.Calculation = xlAutomatic  'включаем автоматический пересчет формул
        .ScreenUpdating = True     'включаем обновление экрана
End With
End Sub

ActiveWorkbook.SaveAs AccessMode:=xlShared 

If ActiveWorkbook.MultiUserEditing Then
    ActiveWorkbook.ExclusiveAccess
End If