VBA 函数到 Return 基于列范围的查找值
VBA Function to Return LOOKUP Values Based on Column Range
我对 VBA 比较陌生，需要社区对以下逻辑的帮助。
我有以下 table
我的实际数据Table如下
我的预期输出如下：
我尝试对 cat 代码使用索引值并尝试过，但我被困在这里的逻辑而无法继续。感谢您的帮助。
注意：Actual 数据不需要包含 Catcode，例如属于 CatCode A 的值并不总是在值中包含 A。我会将两个 catcode 之间的所有值归类到它后面的 cat 代码。
基于列范围的查找
调整 constants 部分中的值（例如 sheet 名称可以完全相同，第一行或第一列可以不同等）。
新版本
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
我对 VBA 比较陌生，需要社区对以下逻辑的帮助。 我有以下 table
我的实际数据Table如下
我的预期输出如下：
我尝试对 cat 代码使用索引值并尝试过，但我被困在这里的逻辑而无法继续。感谢您的帮助。
注意：Actual 数据不需要包含 Catcode，例如属于 CatCode A 的值并不总是在值中包含 A。我会将两个 catcode 之间的所有值归类到它后面的 cat 代码。
基于列范围的查找
调整 constants 部分中的值（例如 sheet 名称可以完全相同，第一行或第一列可以不同等）。
新版本
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