Option Explicit
Sub TransformDataWithFillColorsAndCorrectStart()
Dim wsSource As Worksheet, wsDest As Worksheet
Dim sourceRange As Range, destRange As Range
Dim sourceRow As Range
Dim destRow As Range
Dim colMap As Object
Dim lastRow As Long
Dim destRowCounter As Long
Dim currentRow As Long
Dim colIndex As Variant
Dim cell As Range, destCell As Range
Set wsSource = ThisWorkbook.Sheets("Master Tab")
Set wsDest = ThisWorkbook.Sheets("Master Tab Complete")
Application.ScreenUpdating = False
wsDest.Cells.Clear
lastRow = wsSource.Cells(wsSource.Rows.Count, "C").End(xlUp).Row
Set sourceRange = wsSource.Range("C3:T" & lastRow)
Set destRange = wsDest.Range("C3")
Set colMap = CreateObject("Scripting.Dictionary")
colMap.Add 3, 3
colMap.Add 4, 4
colMap.Add 8, 5
colMap.Add 9, 6
colMap.Add 13, 7
colMap.Add 17, 8
colMap.Add 18, 9
destRowCounter = destRange.Row
For Each sourceRow In sourceRange.Rows
currentRow = sourceRow.Row
If Not IsEmpty(wsSource.Cells(currentRow, "C")) Then
For Each cell In wsSource.Range(wsSource.Cells(currentRow, "C"), wsSource.Cells(currentRow, "D"))
Set destCell = wsDest.Cells(destRowCounter, cell.Column)
destCell.Value = cell.Value
destCell.Interior.Color = cell.Interior.Color
With destCell.Font
.Name = cell.Font.Name
.Size = cell.Font.Size
.Bold = cell.Font.Bold
.Italic = cell.Font.Italic
.Underline = cell.Font.Underline
.Color = cell.Font.Color
End With
destCell.Borders.Weight = cell.Borders.Weight
Next cell
For Each colIndex In colMap.Keys
If Not IsEmpty(wsSource.Cells(currentRow, colIndex)) Then
Set destCell = wsDest.Cells(destRowCounter, colMap(colIndex))
destCell.Value = wsSource.Cells(currentRow, colIndex).Value
destCell.Interior.Color = wsSource.Cells(currentRow, colIndex).Interior.Color
With destCell.Font
.Name = wsSource.Cells(currentRow, colIndex).Font.Name
.Size = wsSource.Cells(currentRow, colIndex).Font.Size
.Bold = wsSource.Cells(currentRow, colIndex).Font.Bold
.Italic = wsSource.Cells(currentRow, colIndex).Font.Italic
.Underline = wsSource.Cells(currentRow, colIndex).Font.Underline
.Color = wsSource.Cells(currentRow, colIndex).Font.Color
End With
destCell.Borders.Weight = wsSource.Cells(currentRow, colIndex).Borders.Weight
End If
Next colIndex
destRowCounter = destRowCounter + 1
End If
Next sourceRow
For Each destRow In wsDest.Range("C3:L" & destRowCounter - 1).Rows
For colIndex = 5 To 9
If IsEmpty(destRow.Cells(1, colIndex).Value) Then
destRow.Cells(1, colIndex).Value = "Not on File"
With destRow.Cells(1, colIndex)
.Interior.Color = RGB(255, 255, 204)
.Font.Italic = True
End With
End If
Next colIndex
Next destRow
' Set font type and size for the entire sheet "Master Tab Complete"
With wsDest.Cells
.Font.Name = "Arial"
.Font.Size = 12
End With
Worksheets("Master Tab Complete").Columns("A:K").AutoFit
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Data transformed successfully with full formatting and cell colors! Output is in 'Master Tab Complete'."
End Sub| 1 Site Orientation (Offsite) | Safety Watch Orientation | CBT Badge | Contractor Orientation | Site-Specific | Safety Orientation | Safety Orientation Annual Renewal | Notes |
Sub test()
Dim myAreas As Areas, r As Range, c As Range, s$, sp As Shape, HD()
Dim a, i&, ws As Worksheet, myNames, dic As Object, xx As Single
xx = Timer
Set dic = CreateObject("Scripting.Dictionary")
Set ws = Sheets("Master Tab Complete")
ws.UsedRange.Clear
For Each sp In ws.Shapes
sp.Delete
Next
Set myAreas = Sheets("master tab").Rows(3).SpecialCells(2).Areas
ReDim myNames(1 To ws.UsedRange.Count), HD(1 To 2)
HD(1) = myAreas(1).Cells(1): HD(2) = myAreas(1).Cells(2)
For Each r In myAreas
Set c = r.CurrentRegion
a = c.Value
For i = 3 To UBound(a, 2)
ReDim Preserve HD(1 To UBound(HD) + 1): HD(UBound(HD)) = a(1, i)
Next
For i = 2 To UBound(a, 1)
If a(i, 1) <> "" Then
s = Join(Array(a(i, 1), a(i, 2)), Chr(2))
If Not dic.exists(s) Then
Set dic(s) = c(i, 1).Resize(c(i, 1).MergeArea.Rows.Count, UBound(a, 2))
myNames(dic.Count) = s
End If
End If
Next
Next
ReDim Preserve HD(1 To UBound(HD) + 1): HD(UBound(HD)) = "Notes"
ReDim Preserve myNames(1 To dic.Count)
mySort myNames, 1, UBound(myNames)
GetAllData myAreas, HD, myNames, dic, ws, 4
MsgBox Timer - xx
End Sub
Sub GetAllData(myAreas As Areas, HD, myNames, dic As Object, ws As Worksheet, x&)
Dim a, i&, ii&, t&, s$, c As Range, n&, ff$
Application.ScreenUpdating = False
n = x
For i = 1 To UBound(myNames)
s = myNames(i)
dic(s).Copy ws.Cells(n, 3)
Set dic(s) = ws.Cells(n, 3)
n = n + dic(s).Cells(1).MergeArea.Rows.Count
Next
For i = 2 To myAreas.Count
Set c = myAreas(i).CurrentRegion
a = c.Value: t = t + myAreas(i - 1).CurrentRegion.Columns.Count - 2
For ii = 2 To UBound(a, 1)
If a(ii, 1) <> "" Then
s = Join(Array(a(ii, 1), a(ii, 2)), Chr(2))
c(ii, 3).Resize(c(ii, 1).MergeArea.Rows.Count, UBound(a, 2) - 2).Copy dic(s).Cells(1, t + 4 - 1)
End If
Next
Next
ws.UsedRange.Font.Size = 12
Set c = ws.Cells.Find("not on file", , , 1)
Application.DisplayAlerts = False
If Not c Is Nothing Then
ff = c.Address
Do
c.Resize(c.EntireRow.Range("c1").MergeArea.Rows.Count).Merge
Set c = ws.Cells.FindNext(c)
Loop While ff <> c.Address
End If
Application.DisplayAlerts = True
With ws.Cells(x - 1, 3).Resize(, UBound(HD))
.Value = HD
.HorizontalAlignment = xlCenter
.Font.Bold = True: .Font.Color = vbWhite
.Interior.Color = 3484450
.Borders(11).Weight = 2
.Borders(11).Color = vbWhite
.WrapText = True
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub mySort(Ary, LB, UB)
Dim i As Long, ii As Long, M, temp
i = UB: ii = LB
M = Ary(Int((LB + UB) / 2))
Do While ii <= i
Do While Ary(ii) < M: ii = ii + 1: Loop
Do While Ary(i) > M: i = i - 1: Loop
If ii <= i Then
temp = Ary(i): Ary(i) = Ary(ii): Ary(ii) = temp
i = i - 1: ii = ii + 1
End If
Loop
If LB < i Then mySort Ary, LB, i
If ii < UB Then mySort Ary, ii, UB
End Sub Application.ScreenUpdating = False
Application.DisplayAlerts = False '<--- this line
n = x Next
Application.DisplayAlerts = False '<--- this line
ws.UsedRange.Font.Size = 12
