eu fiz esse código que funciona muito bem, exceto a última parte:
O comportamento de última parte deve ser ".Interior.Cor" e ".Valor" afetada até que a última coluna preenchida, em vez disso, afeta a primeira célula de muitas outras colunas. Qualquer idéias?
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