Neočekávané chování "Pro Každý wks V ActiveWindow.SelectedSheets", to ovlivňuje více sloupci, že by to mělo být

udělal jsem tento kód, který funguje docela dobře, kromě poslední části:

Chování poslední část by měla být ".Interiér.Barva" a ".Hodnota" vliv až do poslední obydlené sloupec, místo toho to má vliv na první buňku mnoho dalších sloupců. Nějaké nápady?

  Sub Sample_Workbook()
        
        'Creation of new workbook
        Application.ScreenUpdating = False        
        Workbooks.Add
        
        Set wb = ActiveWorkbook
        wb.SaveAs ThisWorkbook.Path & "etc.xlsx"
        
        'following variable is declared for sending mail purpose
        SourceWorkbook = ActiveWorkbook.Name
        
        Set this = Workbooks("Sample")
        Set wb = ActiveWorkbook
        Set ws1 = wb.Sheets("Sheet1")
        wb.Sheets.Add After:=Sheets(1)
        Set ws2 = wb.Sheets(2)
        wb.Sheets.Add After:=Sheets(2)
        Set ws3 = wb.Sheets(3)
        ws1.Name = "Sheet1"
        ws2.Name = "Sheet2"
        ws3.Name = "Sheet3"
        
        
        'Model the new excel with the requirements:
        Dim Population, Population2 As Range
        Dim lastRow As Long, firstRow As Long
        Dim sampleSize As Long
        Dim unique As Boolean
        Dim i As Long, d As Long, n As Long
        
        
        'following function perfoms all the calculations and copy and pasting        
            
            doTheJob x, y, z, num, q           
            doTheJob x, y, z, num, q 
            doTheJob x, y, z, num, q 
                
        'copy and paste the remaining sheets from the sample files
            Workbooks.Open ThisWorkbook.Path & "Sample2.xlsx"
                Sheets("Sheetx").Copy After:= _
                 Workbooks(SourceWorkbook).Sheets(6)
            Workbooks("Sample2.xlsx").Close SaveChanges:=False
        
        Application.ScreenUpdating = True
        Application.CutCopyMode = False
        ws1.Select
        wb.Close SaveChanges:=True
        End Sub

'these will make the variable available to all modules of this macro Workbook
Public SourceWorkbook As String
Public this, wb As Workbook
Public data As Range
Public output As Range
Public ws1, ws2, ws3 As Worksheet
Public LastCol As Long
Public wks As Worksheet
Public iCol As Long




'FUNCTION
Sub doTheJob(x As String, y As String, z As String, num As Integer, q As String)

    'beginning logic.
    this.Worksheets(x).Activate

Set Population = Range("a3", Range("a3").End(xlDown))
    sampleSize = this.Worksheets("SNOW Reports").Range(y).Value

Set r = Population
    lastRow = r.Rows.Count + r.Row - 1
    firstRow = r.Row


    For i = 1 To sampleSize
   Do
   
    unique = True
    n = Application.WorksheetFunction.RandBetween(firstRow, lastRow)
    
        For d = 1 To i - 1
        'wb.Sheets(z).Activate
        
          If wb.Sheets(z).Cells(d + 1, 50) = n Then
            unique = False
            Exit For
            End If
        Next d
        
          If unique = True Then
          Exit Do
          End If
        
    Loop
    
    Set data = this.Worksheets(x).Range("a" & n, Range("a" & n).End(xlToRight))
    Set output = wb.Worksheets(z).Range("A" & i + 1)
     
    output.Resize(data.Rows.Count, data.Columns.Count).Value = data.Value
        'THE NEXT LINE IS JUST FOR DELETEING LAST COLUMN PURPOSE
    wb.Worksheets(z).Cells(1, 50) = "REF COL"
    wb.Worksheets(z).Cells(i + 1, 50) = n
    
 this.Worksheets(x).Activate
    
Next i

    'delete REF COL:
       With wb.Sheets(z)
            .Columns(50).Delete
        End With
    
    'copy and paste header:
    Set data = this.Worksheets(x).Range("a2", Range("a2").End(xlToRight))
    Set output = wb.Sheets(z).Range("A1")
    
    output.Resize(data.Rows.Count, data.Columns.Count).Value = data.Value
     
'_________________________________________________________________________________________________________

'copy and paste into new sheet with recorded macro
    
   wb.Activate
   Sheets.Add(After:=Sheets(num)).Name = q
   wb.Worksheets(z).Cells.Copy Destination:=wb.Worksheets(q).Range("A1")
             
    'create columns and add color and text dinamically
    For Each wks In ActiveWindow.SelectedSheets
        With wks
            For iCol = .Cells.SpecialCells(xlCellTypeLastCell).Column To 2 Step -1
                .Columns(iCol).Insert
                With Cells(1, iCol)
                .Interior.Color = 65535
                .Value = Cells(1, iCol - 1) & " - Comparison"
                End With
            Next iCol
        End With
    Next wks

End Sub