Transform Workbook
- Копирует диапазон несмежных столбцов каждой (исходной) рабочей таблицы в недавно добавленную (целевую) рабочую таблицу, а затем удаляет исходную рабочую таблицу и переименовывает целевую рабочую таблицу в имяисходный лист.
- Будут обработаны только работа листов, которых нет в списке исключений .Программа не завершится ошибкой, если в рабочей книге есть диаграммы .
- В версии easy вы должны быть осторожны не запускать программу дважды , потому что вам не понравится результат.В версии advanced это предотвращено.
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
Примечания
Недавно добавленные рабочие листы будут иметь те же имена, что и их предшественники, но будут иметь разные кодовые имена.