VBA Tool

[soccerball]

Hello Guys
i have a big question. I need some help for VBA-Code.
I have got a workbook with nine worksheets. All worksheets have the same structure.
I would like to categorize these worksheets by adding the sheets.
Those Worksheets called:
Worksheet 1 = called T1
Worksheet 2 = called T2
Worksheet 3 = called T3
Worksheet 4 = called T4
Worksheet 5 = called T5
Worksheet 6 = called T6
Worksheet 7 = called T7
Worksheet 8 = called T8
Worksheet 9 = called T9




There a three categories i like to create:


worksheet 1 to 4 (mathematical addition should be elementary) = worksheet "media"
worksheet 5 to 6 (mathematical addition should be elementary) = worksheet "music"
worksheet 7 to 9 (mathematical addition should be elementary) = worksheet "workshop"




The mathematical addition should be elementary. Example:


Matrix (32x5) Worksheet 1 + Matrix (32x5) Worksheet 2 + Matrix (32*5) Worksheet 3 + Matrix (32x5) Worksheet 4 = worksheet "media" (32x5)
Matrix (32x5) Worksheet 5 + Matrix (32x5) Worksheet 6 = worksheet "music" (32x5)
Matrix (32x5) Worksheet 7 + Matrix (32x5) Worksheet 8 + Matrix (32x5) Worksheet 9 = worksheet "workshop" (32x5)




after the three worksheets "media", "music" and "workshop" have been created, the other worksheets T1 to T9 are to be deleted.


Thank you in advance

 

[Fazza]

welcome

Option Explicit


'https://www.mrexcel.com/forum/excel-questions/1082727-vba-tool.html


Const msWORKSHEET_NAME_WITHOUT_SUFFIX As String = "T" 'Expect worksheet names "T1", "T2", "T3", "T4", etc


Sub VBATool()
        
    Application.ScreenUpdating = False
    
    If bActiveFileLooksOK Then
        Call ConsolidateDataFromSheets(FirstSheet:=1, LastSheet:=4, NewSheetName:="media")
        Call ConsolidateDataFromSheets(FirstSheet:=5, LastSheet:=6, NewSheetName:="music")
        Call ConsolidateDataFromSheets(FirstSheet:=7, LastSheet:=9, NewSheetName:="workshop")
    Else
        MsgBox "No change - file not as expected"
    End If


End Sub


Function bActiveFileLooksOK() As Boolean


    Const lSHEETS_COUNT As Long = 9 'Expect worksheet names "T1", "T2", "T3", "T4", ... "T9"
    
    Dim i As Long
    Dim wbk As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim aNamesOfNewWorksheets As Variant
    
    
    aNamesOfNewWorksheets = Array("media", "music", "workshop")
    bActiveFileLooksOK = False
    
    'Check there is an activeworkbook
    On Error Resume Next
    Set wbk = ActiveWorkbook
    If Err = 0 Then
        'And the expected worksheets exist
        For i = 1 To lSHEETS_COUNT
            Set wks = wbk.Worksheets(msWORKSHEET_NAME_WITHOUT_SUFFIX & i)
        Next i
    End If
    
    If Err = 0 Then bActiveFileLooksOK = True
    
    'Also check no existing worksheets have the same name as the to-be-created worksheets
    Set wks = Nothing
    For i = LBound(aNamesOfNewWorksheets) To UBound(aNamesOfNewWorksheets)
        Set wks = wbk.Worksheets(aNamesOfNewWorksheets(i))
        If Not wks Is Nothing Then
            bActiveFileLooksOK = False
            Exit Function
        End If
    Next i
    
    Set wks = Nothing
    Set wbk = Nothing
    
End Function


Sub ConsolidateDataFromSheets(ByVal FirstSheet As Long, ByVal LastSheet As Long, ByVal NewSheetName As String)


    Const bDeleteSourceWorksheetsAfterCopying As Boolean = True


    Const lROWS_TO_COPY As Long = 32
    Const lCOLUMNS_TO_COPY As Long = 5
    
    Dim i As Long
    Dim wks As Excel.Worksheet




    Set wks = Worksheets.Add
    wks.Name = NewSheetName
    
    'Consolidate data to new sheet
    For i = FirstSheet To LastSheet
        Worksheets(msWORKSHEET_NAME_WITHOUT_SUFFIX & i).Range("A1").Resize(lROWS_TO_COPY, lCOLUMNS_TO_COPY).Copy
        wks.Range("A1").PasteSpecial xlPasteValues, xlAdd
    Next i


    'Delete source data sheets
    If bDeleteSourceWorksheetsAfterCopying Then
        Application.DisplayAlerts = False
            For i = FirstSheet To LastSheet
                Worksheets(msWORKSHEET_NAME_WITHOUT_SUFFIX & i).Delete
            Next i
        Application.DisplayAlerts = True
    End If


    Set wks = Nothing


End Sub