Range Array Array Range
Изображение стоит тысячи слов
Левый лист является исходным листом, а правый - результирующим.
Поскольку для cBlnColors установлено значение True , несколько диапазонов окрашиваются, чтобы лучше понять, как работает этот код, и указать преимущества наличия заголовков.
Цвет светло-желтый представляет диапазон данных , в то время как цвет yellow представляет остальные ячейки off limit .
Все неокрашенные ячейки могут использоваться без влияния на результаты в правой рабочей таблице .
cBlnHeadersBelow , установленный на True означает, что данные на выше заголовков (необычно), тогда как значение False будет означать, что данные будут быть ниже заголовков (как обычно).
Заголовки ниже данных с цветами
Еще тысяча
На следующем рисунке показан тот же код , используемый с cBlnHeadersBelow , установленным на False .
желтый диапазон простирается до последней строки (не видно).
Опять же, все неокрашенные ячейки могут использоваться без влияния на результаты в правой рабочей таблице .
Заголовки над данными с цветами
Код
Option Explicit
'*******************************************************************************
' Purpose: In a specified worksheet of a specified workbook, transposes a
' range of data (vertical table!?) to a two-column range in a newly
' created worksheet.
' Arguments (As Constants):
' cStrFile
' The path of the workbook file. If "", then ActiveWorkbook is used.
' cVarWs
' It is declared as variant to be able to use both, the title
' (a string e.g. "Sheet1") or the index (a positive whole number e.g. 1)
' of the worksheet. If "", then ActiveSheet is used.
' cStrTitle
' The contents of the first cell in the headers to be searched for.
' cBlnHeaders
' If True, USE headers.
' If False, do NOT use headers i.e. cBlnHeadersBelow has no effect and the
' first data found by searching by column from "A1" is used as first cell
' and the last found data on the worksheet is used for last cell.
' cBlnHeadersBelow
' If True, the data is ABOVE the headers (Data-Then-Headers).
' If False, the data is as usual BELOW the headers (Headers-Then-Data).
' cStrPaste
' The cell address of the first cell of the resulting range in the new
' worksheet.
' cBlnColors
' If True, and cBlnHeaders is True, then colors are being used i.e. one
' color for the data range, and another for off limits ranges.
' If True, and cBlnHeaders is False, all cells are off limits,
' so only the data range is colored.
' Returns
' A new worksheet with resulting data. No threat to the initial worksheet.
' If you don't like the result, just close the workbook.
'*******************************************************************************
Sub VendorFinder()
Application.ScreenUpdating = False
'***************************************
' Variables
'***************************************
Const cStrFile As String = "" ' "Z:\arrInit List.xlsx"
Const cVarWs As Variant = 1 ' "" for ActiveSheet.
Const cStrTitle As String = "Business" ' Contents of First Cell of Header
Const cBlnHeaders As Boolean = True ' True for Headers
Const cBlnHeadersBelow As Boolean = True ' True for Headers Below Data
Const cStrPaste As String = "A1" ' Resulting First Cell Address
Const cBlnColors As Boolean = True ' Activate Colors
Dim objWb As Workbook ' Workbook to be processed
Dim objWs As Worksheet ' Worksheet to be processed
Dim objTitle As Range ' First Cell of Header
Dim objFirst As Range ' First Cell of Data
Dim objLast As Range ' Last Cell of Data
Dim objResult As Range ' Resulting Range
Dim arrInit As Variant ' Array of Initial Data
Dim arrResult() As Variant ' Array of Resulting Data
Dim lngRows As Long ' Array Rows Counter
Dim iCols As Integer ' Array Columns Counter
Dim lngVendor As Long ' Array Data Counter, Array Row Counter
' ' Debug
' Const r1 As String = vbCr ' Debug Rows Separator
' Const c1 As String = "," ' Debug Columns Separator
'
' Dim str1 As String ' Debug String Builder
' Dim lng1 As Long ' Debug Rows Counter
' Dim i1 As Integer ' Debug Columns Counter
'***************************************
' Workbook
'***************************************
'On Error GoTo WorkbookErr
If cStrFile <> "" Then
Set objWb = Workbooks.Open(cStrFile)
Else
Set objWb = ActiveWorkbook
End If
'***************************************
' Worksheet
'***************************************
' On Error GoTo WorksheetErr
If cVarWs <> "" Then
Set objWs = objWb.Worksheets(cVarWs)
Else
Set objWs = objWb.ActiveSheet
End If
With objWs
' Colors
If cBlnColors = True Then
Dim lngData As Variant: lngData = RGB(255, 255, 153)
Dim lngOffLimits As Variant: lngOffLimits = RGB(255, 255, 0)
Else
.Cells.Interior.ColorIndex = xlNone
End If
' Assumptions:
' 1. Headers is a contiguous range.
' 2. The Headers Title is the first cell of Headers i.e. the first cell
' where cStrTitle is found while searching by rows starting from cell
' "A1".
' 3. The Headers Range spans from the Headers Title to the last cell,
' containing data, on the right.
' 4. All cells to the left and to the right of the Headers Range except
' for the cell adjacent to the right are free to be used i.e. no
' calculation is performed on them. If cBlnHeadersBelow is set to True,
' the cells below the Headers Range are free to be used. Similarly,
' if cBlnHeadersBelow is set to False the cells above are free to be
' used.
' 5. When cBlnHeadersBelow is set to True, the first row of data is
' calculated just using the column of the Headers Title
If cBlnHeaders = True Then ' USE Headers.
' Calculate Headers Title (using cStrTitle as criteria).
Set objTitle = .Cells _
.Find(What:=cStrTitle, After:=.Cells(.Rows.Count, .Columns.Count), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
' Calculate initial first and last cells of data.
If cBlnHeadersBelow Then ' Headers are below data.
' Search for data in column of Headers Title starting from the first
' worksheet's row forwards to the row of Headers Title.
' When first data is found, the first cell is determined.
Set objFirst = .Range(.Cells(1, objTitle.Column), objTitle) _
.Find(What:="*", After:=.Cells(objTitle.Row, objTitle.Column), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
' xlToRight, indicating that Headers Range is contiguous, uses the
' last cell of Headers Range while -1 sets the cells' row, one row above
' the Headers Title, resulting in the last cell range.
Set objLast = objTitle.End(xlToRight).Offset(-1, 0)
' Colors
If cBlnColors = True Then
.Cells.Interior.ColorIndex = xlNone
If objFirst.Row > 1 Then
.Range(.Cells(1, objFirst.Column), _
.Cells(objFirst.Row - 1, objLast.Column)) _
.Interior.color = lngOffLimits
End If
If objLast.Column < .Columns.Count Then
.Range(objTitle, .Cells(objTitle.Row, objLast.Column + 1)) _
.Interior.color = lngOffLimits
Else
.Range(objTitle, .Cells(objTitle.Row, objLast.Column)) _
.Interior.color = lngOffLimits
End If
.Range(objFirst, objLast).Interior.color = lngData
End If
Else ' Headers are above data (usually).
' 1 sets the cells' row, one row below the Headers Title
' resulting in the first cell range.
Set objFirst = objTitle.Offset(1, 0)
' Search for data in column of Headers Title starting from the last
' worksheet's row backwards to the row of Headers Title.
' When first data is found, the last row is determined and combined
' with the last column results in the last cell range.
Set objLast = .Cells( _
.Range(objTitle, .Cells(.Rows.Count, _
objTitle.End(xlToRight).Column)) _
.Find(What:="*", After:=objTitle, _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious) _
.Row, _
_
objTitle.End(xlToRight) _
.Column)
'Colors
If cBlnColors = True Then
.Cells.Interior.ColorIndex = xlNone
If objLast.Row < .Rows.Count Then
.Range(.Cells(objLast.Row + 1, objFirst.Column), _
.Cells(.Rows.Count, objLast.Column)) _
.Interior.color = lngOffLimits
End If
If objLast.Column < .Columns.Count Then
.Range(objTitle, .Cells(objTitle.Row, objLast.Column + 1)) _
.Interior.color = lngOffLimits
Else
.Range(objTitle, .Cells(objTitle.Row, objLast.Column)) _
.Interior.color = lngOffLimits
End If
.Range(objFirst, objLast).Interior.color = lngData
End If
End If
Else ' Do NOT use headers.
' Search for data in any cell from "A1" by column. When first data is
' found, the first cell is determined.
Set objFirst = _
.Cells _
.Find(What:="*", After:=.Cells(.Rows.Count, .Columns.Count), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext)
' Last cell with data on the worksheet.
Set objLast = .Cells( _
_
.Cells _
.Find(What:="*", After:=.Cells(1, 1), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious) _
.Row, _
_
.Cells _
.Find(What:="*", After:=.Cells(1, 1), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) _
.Column)
' Colors
If cBlnColors = True Then
.Cells.Interior.ColorIndex = xlNone
Range(objFirst, objLast).Interior.color = lngData
End If
End If
End With
'***************************************
' arrInit
'***************************************
' On Error GoTo arrInitErr
' Paste the values (Value2) of initial range into initial array (arrInit).
arrInit = Range(objFirst, objLast).Value2
' ' Debug
' str1 = r1 & "Initial Array (arrInit)" & r1
' For lng1 = LBound(arrInit) To UBound(arrInit)
' str1 = str1 & r1
' For i1 = LBound(arrInit, 2) To UBound(arrInit, 2)
' If i1 <> 1 Then
' str1 = str1 & c1
' End If
' str1 = str1 & arrInit(lng1, i1)
' Next
' Next
' Debug.Print str1
' Count data in arrInit.
For lngRows = LBound(arrInit) To UBound(arrInit)
For iCols = LBound(arrInit, 2) To UBound(arrInit, 2)
If arrInit(lngRows, iCols) <> "" Then
lngVendor = lngVendor + 1
End If
Next
Next
'***************************************
' arrResult
'***************************************
' On Error GoTo arrResultErr
ReDim arrResult(1 To lngVendor, 1 To 2) ' Resize resulting array (arrResult).
lngVendor = 0 ' Reset array data counter to be used as array row counter.
' Loop through arrInit and write to arrResult.
For lngRows = LBound(arrInit) To UBound(arrInit)
For iCols = LBound(arrInit, 2) To UBound(arrInit, 2)
If arrInit(lngRows, iCols) <> "" Then
lngVendor = lngVendor + 1
If iCols = 1 Then
arrResult(lngVendor, 1) = arrInit(lngRows, iCols)
Else
arrResult(lngVendor, 1) = arrResult(lngVendor - 1, 1)
End If
arrResult(lngVendor, 2) = arrInit(lngRows, iCols)
End If
Next
Next
Erase arrInit ' Data is in arrResult.
' ' Debug
' str1 = r1 & "Resulting Array (arrResult)" & r1
' For lng1 = LBound(arrResult) To UBound(arrResult)
' str1 = str1 & r1
' For i1 = LBound(arrResult, 2) To UBound(arrResult, 2)
' If i1 <> 1 Then
' str1 = str1 & c1
' End If
' str1 = str1 & arrResult(lng1, i1)
' Next
' Next
' Debug.Print str1
' Since there is only an infinite number of possibilities what to do with the
' resulting array, pasting it into a new worksheet has been chosen to be able
' to apply the bold formatting of the "Business Names" requested.
'***************************************
' New Worksheet
'***************************************
On Error GoTo NewWorksheetErr
Worksheets.Add After:=objWs
Set objResult = ActiveSheet.Range(Range(cStrPaste), _
Range(cStrPaste).Offset(UBound(arrResult) - 1, _
UBound(arrResult, 2) - 1))
With objResult
' Paste arrResult into resulting range (objResult).
.Value2 = arrResult
' Apply some formatting.
For lngRows = LBound(arrResult) To UBound(arrResult)
' If .Cells(lngRows, 1) = .Cells(lngRows, 2) Then ' Too slow!
If arrResult(lngRows, 1) = arrResult(lngRows, 2) Then
.Cells(lngRows, 1).Font.Bold = True
End If
Next
Erase arrResult ' Data is in objResult.
.Columns.AutoFit
End With
' To suppress the "Do you want to save changes you made to ... ?" - Alert:
objWb.Saved = True
'***************************************
' Clean Up
'***************************************
NewWorksheetExit:
Set objResult = Nothing
WorksheetExit:
Set objLast = Nothing
Set objFirst = Nothing
Set objTitle = Nothing
Set objWs = Nothing
WorkbookExit:
Set objWb = Nothing
Application.ScreenUpdating = True
Exit Sub
'***************************************
' Errors
'***************************************
WorkbookErr:
MsgBox "Workbook Error" & " (Error: '" & Err.Number & "')"
GoTo WorkbookExit
WorksheetErr:
MsgBox "Worksheet Error" & " (Error: '" & Err.Number & "')"
GoTo WorksheetExit
arrInitErr:
MsgBox "arrInit Error" & " (Error: '" & Err.Number & "')"
GoTo WorksheetExit
arrResultErr:
MsgBox "arrResult Error" & " (Error: '" & Err.Number & "')"
GoTo WorksheetExit
NewWorksheetErr:
MsgBox "New Worksheet Error" & " (Error: '" & Err.Number & "')"
GoTo NewWorksheetExit
End Sub
'*******************************************************************************
Дополнительно
Во время тестирования кода в рабочей книге было немного слишком много рабочих листов , поэтому я написал следующее:
'*******************************************************************************
' Purpose: Deletes all Worksheets in the ActiveWorkbook except one.
' Danger: This code doesn't ask anything, it just does. In the end you will
' end up with just one worksheet (cStrWsExcept) in the workbook
' (cStrWbPath). If you have executed this code and the result is not
' satisfactory, just close the workbook and try again or don't. There
' will be no alert like "Do you want to save ..." because of the line:
' ".Saved = True" i.e. "objWb.Saved = True".
' Arguments (As Constants):
' cStrWbPath
' The path of the workbook to be processed. If "", then ActiveWorkbook is
' used.
' cStrWsExcept
' The worksheet not to be deleted. If "", then the Activesheet is used.
'*******************************************************************************
Sub DeleteWorksheetsExceptOne()
Const cStrWbPath = "" ' if "" then ActiveWorkbook
Const cStrWsExcept = "Sheet1" ' if "" then ActiveSheet
Dim objWb As Workbook
Dim objWsExcept As Worksheet
Dim objWsDelete As Worksheet
If cStrWbPath = "" Then
Set objWb = ActiveWorkbook
Else
Set objWb = Workbooks(cStrWbPath)
End If
With objWb
If cStrWsExcept = "" Then
Set objWsExcept = .ActiveSheet
Else
Set objWsExcept = .Worksheets(cStrWsExcept)
End If
' To suppress the "Data may exist in the sheet(s) selected for deletion.
' To permanently delete the data, press Delete." - Alert:
Application.DisplayAlerts = False
For Each objWsDelete In .Worksheets
If objWsDelete.Name <> objWsExcept.Name Then
objWsDelete.Delete
End If
Next
' To suppress the "Do you want to save changes you made to ... ?" - Alert:
.Saved = True
Application.DisplayAlerts = True
End With
End Sub
'*******************************************************************************