Поиск на основе диапазона столбцов
Настройте значения в разделе константы (например, имена листов могут быть одинаковыми, первые строки или столбцы могут отличаться и т. Д. c .).
Новая версия
Option Explicit
Sub LookupBasedOnColumnRange()
Const Head1 As String = "CatCode" ' 1st Column Header
Const Head2 As String = "Values" ' 2nd Column Header
Const cSheet As String = "Sheet1" ' CatCode Sheet Name
Const cFR As Long = 2 ' CatCode First Row Number (no header)
Const cCol As Variant = 1 ' CatCode Column (e.g. 1 or "A")
Const aSheet As String = "Sheet2" ' Actual Sheet Name
Const aFR As Long = 2 ' Actual First Row Number (no header)
Const aCol As Variant = 1 ' Actual Column (e.g. 1 or "A")
Const rSheet As String = "Sheet3" ' Result Sheet Name
Const rCel As String = "A1" ' Result First Cell Range Address
Dim rng As Range ' CatCode Non-Empty 1-Column Range,
' Actual Non-Empty 1-Column Range,
' Result 2-Column Range
Dim CatCode As Variant ' CatCode Array
Dim Actual As Variant ' Actual Array
Dim Result As Variant ' Result Array
Dim i As Long ' CatCode Array Elements Counter
Dim j As Long ' Actual Array Elements Counter,
' Result Array 1st Dimension (Rows) Elements Counter
' Change to "As Long" if only numbers
' or to "As Variant" if there are numbers and strings.
Dim CurC As String ' Current CatCode
Dim CurA As String ' Current Actual
' Write ranges to arrays.
With ThisWorkbook.Worksheets(cSheet)
Set rng = .Columns(cCol).Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
CatCode = .Range(.Cells(cFR, cCol), rng)
End With
With ThisWorkbook.Worksheets(aSheet)
Set rng = .Columns(aCol).Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
Actual = .Range(.Cells(aFR, aCol), rng)
End With
Set rng = Nothing
' Resize Result Array (Same first dimension (rows) as Actual Array).
ReDim Result(1 To UBound(Actual) + 1, 1 To 2) ' '+1' for headers
' Write headers to Result Array.
Result(1, 1) = Head1
Result(1, 2) = Head2
' Calculate and write data to Result Array.
j = 1
On Error GoTo ErrorHandler
For i = 1 To UBound(CatCode)
CurC = CatCode(i, 1)
Do
' If CatCode is missing, Run-time error '9'.
CurA = Actual(j, 1)
Result(j + 1, 1) = CurC
Result(j + 1, 2) = CurA
j = j + 1
Loop Until CurA = CurC Or j = UBound(Result) + 1
' "j = UBound(Result) + 1" prevents infinite loop
' if CatCode missing.
Next i
On Error GoTo 0
' Erase arrays not needed anymore.
Erase CatCode
Erase Actual
With ThisWorkbook.Worksheets(rSheet)
' Clear contents of columns of Result Range.
.Range(rCel).Resize(.Rows.Count - Range(rCel).Row + 1, 2).ClearContents
' Define Result Range.
Set rng = .Range(rCel).Resize(UBound(Result), UBound(Result, 2))
End With
' Copy Result Array to Result Range.
rng = Result
' Inform user.
MsgBox "Transferred Result(" & UBound(Result) & "x" & UBound(Result, 2) _
& ").", vbInformation, "Custom Message"
GoTo exitProcedure
ErrorHandler:
If Err.Number = 9 Then
MsgBox "CatCode '" & CurC & "' missing.", vbCritical, "Custom Message"
Err.Clear: GoTo exitProcedure
End If
If Err.Number > 0 Then
MsgBox "An unexpected error occurred. Error '" _
& Err.Number & "': " & Err.Description, vbCritical, "Custom Message"
Err.Clear: GoTo exitProcedure
End If
exitProcedure:
End Sub
Улучшена старая версия
Option Explicit
Sub LookupBasedOnColumnRangeFirst()
Const Head1 As String = "CatCode" ' 1st Column Header
Const Head2 As String = "Values" ' 2nd Column Header
Const cSheet As String = "Sheet1" ' CatCode Sheet Name
Const cFR As Long = 2 ' CatCode First Row Number (no header)
Const cCol As Variant = 1 ' CatCode Column (e.g. 1 or "A")
Const aSheet As String = "Sheet2" ' Actual Sheet Name
Const aFR As Long = 2 ' Actual First Row Number (no header)
Const aCol As Variant = 1 ' Actual Column (e.g. 1 or "A")
Const rSheet As String = "Sheet3" ' Result Sheet Name
Const rCel As String = "A1" ' Result First Cell Range Address
Dim rng As Range ' CatCode Non-Empty 1-Column Range,
' Actual Non-Empty 1-Column Range,
' Result 2-Column Range
Dim CatCode As Variant ' CatCode Array
Dim Actual As Variant ' Actual Array
Dim Result As Variant ' Result Array
Dim i As Long ' CatCode Array Elements Counter
Dim j As Long ' Actual Array Elements Counter
Dim k As Long ' Result Array 1st Dimension (Rows) Elements Counter
' Write ranges to arrays.
With ThisWorkbook.Worksheets(cSheet)
Set rng = .Columns(cCol).Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
CatCode = .Range(.Cells(cFR, cCol), rng)
End With
With ThisWorkbook.Worksheets(aSheet)
Set rng = .Columns(aCol).Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
Actual = .Range(.Cells(aFR, aCol), rng)
End With
Set rng = Nothing
' The following line assumes that all 'data is valid'. If not then
' Result Array will have empty elements at the end (probably no harm done,
' but definately 'not correct'.
' Resize Result Array (Same first dimension (rows) as Actual Array).
ReDim Result(1 To UBound(Actual) + 1, 1 To 2) ' '+1' for headers
' Write headers to Result Array.
Result(1, 1) = Head1
Result(1, 2) = Head2
' Calculate and write data to Result Array.
k = 2
For i = 1 To UBound(CatCode)
For j = 1 To UBound(Actual)
If Actual(j, 1) Like CatCode(i, 1) & "*" Then
Result(k, 1) = CatCode(i, 1)
Result(k, 2) = Actual(j, 1)
k = k + 1
End If
Next j
Next i
' Note: The previous For Next Loop always loops through all elements
' of Actual Array allowing it to be unsorted.
' Erase arrays not needed anymore.
Erase CatCode
Erase Actual
With ThisWorkbook.Worksheets(rSheet)
' Clear contents of columns of Result Range.
.Range(rCel).Resize(.Rows.Count - Range(rCel).Row + 1, 2).ClearContents
' Define Result Range.
Set rng = .Range(rCel).Resize(UBound(Result), UBound(Result, 2))
End With
' Copy Result Array to Result Range.
rng = Result
' Inform user.
MsgBox "Transferred Result(" & UBound(Result) & "x" & UBound(Result, 2) _
& ").", vbInformation, "Custom Message"
End Sub