Transform Workbook
- Copies a range of not contiguous columns of each (source) worksheet
to a newly added (target) worksheet and then deletes the source
worksheet and renames the target worksheet to the name of the source
worksheet.
- Only worksheets that are not in the Exception List will be
processed. The program will not fail if there are charts in
the workbook.
- In the easy version, you have to be careful not to run the
program twice, because you won't like the result. This is prevented
in the advanced version.
Easy
Sub WorksheetLoopFormatEasy()
Const cExc As String = "Sheet1" ' Worksheet Exception List
Const cSrc As String = "C:C,G:G,I:I,AN:AN" ' Source Range Address
Const cTgt As String = "A1" ' Target Cell Range Address
Dim wsS As Worksheet ' Source Worksheet
Dim wsT As Worksheet ' Target Worksheet
Dim vntE As Variant ' Exception Array
Dim i As Long ' Exception Array Element (Name) Counter
Dim strS As String ' Source Worksheet Name
' Copy Exception List to Exception Array.
vntE = Split(cExc, ",")
' In This Workbook (i.e. the workbook containing this code.)
With ThisWorkbook
' Loop through all Source Worksheets.
For Each wsS In .Worksheets
' Loop through elements (names) of Exception Array.
For i = 0 To UBound(vntE)
' Check if current name in exception array equals the current
' Worksheet name.
If Trim(vntE(i)) = wsS.Name Then Exit For ' Match found
Next
' Note: Exception Array is a zero-based one-dimensional array.
' If a match is NOT found, "i" will be equal to the number of
' names in Exception Array (i.e. UBound(vntE) + 1).
If i = UBound(vntE) + 1 Then
' Add a new worksheet (Target Worksheet) after Source Worksheet.
' Note: The newly added worksheet will become the ActiveSheet
' and will become the Target Worksheet.
.Sheets.Add After:=wsS
' Create a reference to Target Worksheet.
Set wsT = .ActiveSheet
' Copy Source Range to Target Range.
wsS.Range(cSrc).Copy Destination:=wsT.Range(cTgt)
' Write source worksheet name to Source Worksheet Name.
strS = wsS.Name
' Delete Source Worksheet.
' Note: Disabling DisplayAlerts suppresses showing
' of the 'delete message box'.
Application.DisplayAlerts = False
wsS.Delete
Application.DisplayAlerts = True
' Rename Target Worksheet to Source Worksheet Name.
wsT.Name = strS
End If
Next
End With
MsgBox "The program has finished successfully.", vbInformation, "Success"
End Sub
Advanced
Sub WorksheetLoopFormatAdvanced()
Const cExc As String = "Sheet1" ' Worksheet Exception List
Const cSrc As String = "C:C,G:G,I:I,AN:AN" ' Source Range Address
Const cTgt As String = "A1" ' Target Cell Range Address
Dim wsS As Worksheet ' Source Worksheet
Dim wsT As Worksheet ' Target Worksheet
Dim vntE As Variant ' Exception Array
Dim i As Long ' Exception Array Element (Name) Counter
Dim lngA As Long ' Area Counter
Dim lngC As Long ' Source Range Columns Count(er)
Dim strS As String ' Source Worksheet Name
Dim strA As String ' ActiveSheet Name
' Speed up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Handle Errors.
On Error GoTo ErrorHandler
' Copy Exception List to Exception Array.
vntE = Split(cExc, ",")
' In This Workbook (i.e. the workbook containing this code.)
With ThisWorkbook
' Write the name of ActiveSheet to ActiveSheet Name.
strA = .ActiveSheet.Name
' Loop through all Source Worksheets.
For Each wsS In .Worksheets
'*******************************'
' Prevent Double Transformation '
'*******************************'
' Calculate Source Range Columns Count if not already calculated.
If lngC = 0 Then
' Loop through Areas of Source Range.
For lngA = 1 To wsS.Range(cSrc).Areas.Count
' Count the columns in current area.
lngC = lngC + wsS.Range(cSrc).Areas(lngA).Columns.Count
Next
' Check if number of used columns in Source Worksheet is equal
' to the number of columns of Source Range.
If wsS.Cells.Find("*", , xlFormulas, , xlByColumns, _
xlPrevious).Column - wsS.Range(cTgt).Column + 1 _
<= lngC Then GoTo DoubleTransformationError
End If
'*****************
' Transform Data '
'*****************
' Loop through elements (names) of Exception Array.
For i = 0 To UBound(vntE)
' Check if current name in exception array equals the current
' Worksheet name.
If Trim(vntE(i)) = wsS.Name Then Exit For ' Match found
Next
' Note: Exception Array is a zero-based one-dimensional array.
' If a match is NOT found, "i" will be equal to the number of
' names in Exception Array (i.e. UBound(vntE) + 1).
If i = UBound(vntE) + 1 Then
' Add a new worksheet (Target Worksheet) after Source Worksheet.
' Note: The newly added worksheet will become the ActiveSheet
' and will become the Target Worksheet.
.Sheets.Add After:=wsS
' Create a reference to Target Worksheet.
Set wsT = .ActiveSheet
' Copy Source Range to Target Range.
wsS.Range(cSrc).Copy Destination:=wsT.Range(cTgt)
' Write source worksheet name to Source Worksheet Name.
strS = wsS.Name
' Delete Source Worksheet.
' Note: Disabling DisplayAlerts suppresses showing
' of the 'delete message box'.
Application.DisplayAlerts = False
wsS.Delete
Application.DisplayAlerts = True
' Rename Target Worksheet to the name of Source Worksheet.
wsT.Name = strS
End If
Next
End With
MsgBox "The program has finished successfully.", vbInformation, "Success"
ProcedureExit:
' Activate worksheet that was active before program execution.
ThisWorkbook.Worksheets(strA).Activate
' Speed down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
DoubleTransformationError:
MsgBox "The program has already run.", vbInformation, _
"Double Transformation Prevention"
GoTo ProcedureExit
ErrorHandler:
MsgBox "An unexpected error has occurred. Error '" & Err.Number & "': " _
& Err.Description, vbInformation, "Error"
GoTo ProcedureExit
End Sub
Remarks
The newly added worksheets will have the same names as their predecessors but will have different code names.
