Copy content of variable table into newly created sheets

[EricMA]

Hi,

A powerquery creates a table on a sheet 'HandoverDocumentList'. This tabels alters when changing the value in cell 'B3' (list of buildings) of this same worksheet and this cell has a datavalidation list behind it. Changing this value updates the table automatically using this code. So far so good.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Dim KeyCells2 As Range


' The variable KeyCells contains the cells that will cause an alert when they are changed.

    Set KeyCells = Range("B3")
    Set KeyCells2 = Range("A5:M500")

    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then

' Display a message when one of the designated cells has been changed.

        ActiveWorkbook.Connections("Query - Handover_Documents").Refresh
        
        Sheets("Pivot Handover docs").PivotTables("Pivot_Handover_Documents").RefreshTable

End If
    
    If Not Application.Intersect(KeyCells2, Range(Target.Address)) _
           Is Nothing Then

' Display a message when one of the designated cells has been changed.

        Sheets("Pivot Handover docs").PivotTables("Pivot_Handover_Documents").RefreshTable
        
    ActiveWorkbook.Worksheets("HandoverDocumentList").ListObjects( _
        "Handover_Documents").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("HandoverDocumentList").ListObjects( _
        "Handover_Documents").Sort.SortFields.Add2 Key:=Range( _
        "Handover_Documents[Package type]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("HandoverDocumentList").ListObjects( _
        "Handover_Documents").Sort.SortFields.Add2 Key:=Range( _
        "Handover_Documents[Package description]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("HandoverDocumentList").ListObjects( _
        "Handover_Documents").Sort.SortFields.Add2 Key:=Range( _
        "Handover_Documents[Description EN]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("HandoverDocumentList").ListObjects( _
        "Handover_Documents").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End If
End Sub

But this next step is the problem. For each value in this datavalidation list a copy of this powerquery table should be copied to a new sheet with as name the current value of the datavalidation list. Even beter would be if all of these created sheets would be saved to a new workbook (last part not yet in next code). Going trough this forum I've compiled this next code. The sheets are created but remain empty. No Error is reported. Can somebody help me to make this work and to improve this code? Is the problem that the code runs faster than the power query can update?

Option Explicit

Sub CopyToSheets_Click()

Call CreateWorksheets(Sheets("Data Validation").Range("Building_Parts[Part Code]"))
Call LoopThroughDataValidationList

End Sub

Sub CreateWorksheets(Names_Of_Sheets As Range)
Dim No_Of_Sheets_to_be_Added As Integer
Dim Sheet_Name As String
Dim i As Integer

No_Of_Sheets_to_be_Added = Names_Of_Sheets.rows.Count

For i = 1 To No_Of_Sheets_to_be_Added

Sheet_Name = Names_Of_Sheets.Cells(i, 1).Value

'Only add sheet if it doesn't exist already and the name is longer than zero characters

If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
    Worksheets.Add(After:=Sheets("Pivot Handover docs")).Name = Sheet_Name
End If

Next i

End Sub
Function Sheet_Exists(WorkSheet_Name As String) As Boolean
Dim Work_sheet As Worksheet

Sheet_Exists = False

For Each Work_sheet In ThisWorkbook.Worksheets

    If Work_sheet.Name = WorkSheet_Name Then
        Sheet_Exists = True
    End If

Next

End Function
Sub ActivateSheet()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    For Each ws In Sheets
        If ws.Name = Range("B3") Then
            Sheets("HandoverDocumentList").Select
            Range("Handover_Documents[#All]").Select
            Application.CutCopyMode = False
            Selection.Copy
            ws.Activate
            ActiveSheet.Select
            Range("A8").Select
            ActiveSheet.Paste
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

Sub LoopThroughDataValidationList()

Dim rng As Range
Dim dataValidationArray As Variant
Dim i As Integer
Dim rows As Integer

    Application.ScreenUpdating = False

'Set the cell which contains the Data Validation list
Set rng = Sheets("HandoverDocumentList").Range("B3")

'If Data Validation list is not a range, ignore errors
On Error Resume Next


'Create an array from the Data Validation formula, without creating
'a multi-dimensional array from the range
rows = Range(Replace(rng.Validation.Formula1, "=", "")).rows.Count
ReDim dataValidationArray(1 To rows)

For i = 1 To rows
    dataValidationArray(i) = _
        Range(Replace(rng.Validation.Formula1, "=", "")).Cells(i, 1)
Next i


'If not a range, then try splitting a string
If Err.Number <> 0 Then
    Err.Clear
    dataValidationArray = Split(rng.Validation.Formula1, ",")
End If


'Some other error has occured so exit sub
If Err.Number <> 0 Then Exit Sub

'Reinstate error checking
On Error GoTo 0


'Loop through all the values in the Data Validation Array
For i = LBound(dataValidationArray) To UBound(dataValidationArray)

    'Change the value in the data validation cell
    rng.Value = dataValidationArray(i)
    
    'Force the sheet to recalculate
    Application.Calculate
    
    Call ActivateSheet
    
    Columns("A:J").Select
    Columns("A:J").EntireColumn.AutoFit
    
    Columns("E:E").Select
    Application.CutCopyMode = False
    Selection.ColumnWidth = 50
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
          
    Columns("F:F").Select
    Application.CutCopyMode = False
    Selection.ColumnWidth = 70
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
          
Next i

    Application.ScreenUpdating = True

End Sub