英文:
Excel VBA code to filter a datatable with specific values
问题
我有一个包含两个工作表的 Excel 文件。
一个名为“Items”的工作表包含一个名为“ItemsTable”的单列表格，其中包含许多条目。数量不重要。我在旁边添加了一个名为“筛选”的按钮以备后用：
其次，我有一个名为“Data”的工作表，其中包含一个名为“DataTable”的表格。在这个表格中，我随机添加了来自ItemsTable的条目（每个单元格都是一个下拉列表，我可以从ItemsTable中选择条目）。可能会有空白单元格。填充后看起来像这样：
到目前为止，就是现有的数据了。接下来我想从这里提取一些数据。
首先，我手动在“Items”工作表上筛选了一些我想要使用的项目，例如这次只选择了梨和香蕉：
现在我希望的是，当我点击“筛选”按钮时，它应该获取所选的项目（在本例中为2个），并检查这些项目是否同时出现在DataTable的行中。它们必须同时出现在一行中，无论以任何顺序出现在该行中，只要它们同时出现即可（或者我选择选择的项目数量）。我的想法是我想要创建一个名为“Stats”的新工作表（如果该工作表已经存在，则删除其内容）并在该工作表上创建一个与“DataTable”表格具有相同标题的新表格，然后将所有符合条件的行添加到新创建的表格中。
因此，在这种情况下，“Stats”工作表将被创建（或者如果它已存在，则清除其内容），并且应在那里添加一个包含以下行的表格：
我在vba中为此筛选按钮创建了一个宏：
Sub Filter()
End Sub
我尝试过很多方法来使用数组和循环来实现这个目标，但每次都遇到了几个问题。甚至在尝试仅使用使用SpecialCells(xlCellTypeVisible)筛选的所选项目时，也会遇到问题。我不会粘贴我尝试过的代码，因为那可能是无用的。有没有人能够帮我编写执行此操作所需的代码？我将永远感激不尽，因为我真的需要让它工作。
英文:
I have an excel with 2 sheets.
A sheet named "Items" contains a single column table named "ItemsTable" with a number of entries. It doesn't matter how many. I added a button "Filter" next to it for later use:
Secondly I have a sheet named "Data" which has a table named "DataTable". In this table I added entries from the ItemsTable randomly (each cell is a dropdown list where I can choose an entry from the ItemsTable). There can be blank cells. It looks like this when filled:
So far for the available data. I want to do some extracting of data from here on.
First I manually filter some items on the "Items" Sheet that I want to use, for example only pear and banana this time:
Now what I want it to do is when I click the "Filter" button, it should take the selected items (2 in this case) and check if these are present at the same time on the rows of the DataTable. They have to be present both on a row, in any order on that row, as long as they are BOTH present (or however many items I chose to select). The idea is that I want to create a new sheet called "Stats" (or delete the content of it if this sheet already exists) and create a new table on that sheet with the same headers as the "DataTable" table and add all rows that fit the criteria there to that newly created table.
So in this case the "Stats" sheet would be created (or cleared of content if it exists) and a table should be added there with the following rows:
I created a macro in vba for this Filter button:
Sub Filter()
End Sub
I've tried many ways to do it using arrays and loops but I run into several issues each time. I'm even running into issues trying to use only the selected items that I filtered using SpecialCells(xlCellTypeVisible). I'm not gonna paste the code I've tried as it will probably be useless. Is there anybody who can help me out with the code necessary to execute this? I would be eternally grateful as I really need this to work.
答案1
得分: 4
"Retrieve Filtered Data"
Sub RetrieveFilterData()
' 定义常量。
' 查找
Const LKP_SHEET As String = "Items"
Const LKP_TABLE As Variant = 1 ' 或例如 "Items"
Const LKP_COLUMN As Variant = "Items"
' 源
Const SRC_SHEET As String = "Data"
' 目标
Const DST_SHEET As String = "Stats"
Const DST_TABLE As String = "Stats"
Dim dColumns(): dColumns = VBA.Array(1, 2, 3, 4)
Dim wb As Workbook: Set wb = ThisWorkbook ' 包含此代码的工作簿
' 引用查找范围（查找列中的筛选行）。
Dim lws As Worksheet: Set lws = wb.Sheets(LKP_SHEET)
Dim llo As ListObject: Set llo = lws.ListObjects(LKP_TABLE)
Dim llc As ListColumn: Set llc = llo.ListColumns(LKP_COLUMN)
Dim lrg As Range
On Error Resume Next
Set lrg = llc.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' 引用源工作表。
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
' 删除目标工作表。
Dim dws As Worksheet
On Error Resume Next
Set dws = wb.Sheets(DST_SHEET)
On Error GoTo 0
If Not dws Is Nothing Then
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
End If
' 将源复制为目标工作表。
sws.Copy After:=wb.Sheets(wb.Sheets.Count)
Set dws = wb.Sheets(wb.Sheets.Count)
dws.Name = DST_SHEET
' 假设第一个源或目标表格：
Dim dlo As ListObject: Set dlo = dws.ListObjects(1)
dlo.Name = DST_TABLE
' 清除筛选器。
If dlo.ShowAutoFilter Then
If dlo.AutoFilter.FilterMode Then
dlo.AutoFilter.ShowAllData
End If
End If
' 如果没有筛选。
If lrg Is Nothing Then
dlo.DataBodyRange.Delete
MsgBox "没有要查找的数据。", vbExclamation
Exit Sub
End If
' 将筛选的字符串写入字典。
Dim lDict As Object: Set lDict = CreateObject("Scripting.Dictionary")
lDict.CompareMode = vbTextCompare
Dim lCell As Range, lStr As String
For Each lCell In lrg.Cells
lStr = CStr(lCell.Value)
If Len(lStr) > 0 Then
If Not lDict.Exists(lStr) Then
lDict(lStr) = Empty
End If
End If
Next lCell
If lDict.Count = 0 Then
dlo.DataBodyRange.Delete
MsgBox "只找到空白。", vbCritical
Exit Sub
End If
' 将源或目标数据写入数组。
Dim drg As Range: Set drg = dlo.DataBodyRange
Dim dData(): dData = drg.Value
' 将匹配的数据写入数组顶部。
Dim nUpper As Long: nUpper = UBound(dColumns)
Dim rCount As Long: rCount = UBound(dData, 1)
Dim cCount As Long: cCount = UBound(dData, 2)
Dim lKey, r As Long, dr As Long, c As Long, n As Long
Dim dStr As String, IsNotFound As Boolean
For r = 1 To rCount
For Each lKey In lDict.Keys
For n = 0 To nUpper
c = dColumns(n)
dStr = dData(r, c)
If StrComp(dStr, lKey, vbTextCompare) = 0 Then
Exit For
End If
Next n
If n > nUpper Then
IsNotFound = True
Exit For
End If
Next lKey
If IsNotFound Then
IsNotFound = False
Else
dr = dr + 1
For c = 1 To cCount
dData(dr, c) = dData(r, c)
Next c
End If
Next r
If dr = 0 Then
dlo.DataBodyRange.Delete
MsgBox "没有找到匹配项。", vbExclamation
Exit Sub
End If
' 将数组顶部的匹配数据写入目标表格。
drg.Resize(dr, cCount).Value = dData
' 删除剩余的（表格）行。
If dr < rCount Then
drg.Resize(rCount - dr).Offset(dr).Delete xlShiftUp
End If
' 通知。
MsgBox "已检索筛选数据。", vbInformation
End Sub
英文:
Retrieve Filtered Data
<!-- language: lang-vb -->
Sub RetrieveFilterData()
' Define constants.
' Lookup
Const LKP_SHEET As String = "Items"
Const LKP_TABLE As Variant = 1 ' or e.g. "Items"
Const LKP_COLUMN As Variant = "Items"
' Source
Const SRC_SHEET As String = "Data"
' Destination
Const DST_SHEET As String = "Stats"
Const DST_TABLE As String = "Stats"
Dim dColumns(): dColumns = VBA.Array(1, 2, 3, 4)
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the lookup range (the filtered rows in the lookup column).
Dim lws As Worksheet: Set lws = wb.Sheets(LKP_SHEET)
Dim llo As ListObject: Set llo = lws.ListObjects(LKP_TABLE)
Dim llc As ListColumn: Set llc = llo.ListColumns(LKP_COLUMN)
Dim lrg As Range
On Error Resume Next
Set lrg = llc.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' Reference the source worksheet.
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
' Delete the destination worksheet.
Dim dws As Worksheet
On Error Resume Next
Set dws = wb.Sheets(DST_SHEET)
On Error GoTo 0
If Not dws Is Nothing Then
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
End If
' Copy the source as the destination worksheet.
sws.Copy After:=wb.Sheets(wb.Sheets.Count)
Set dws = wb.Sheets(wb.Sheets.Count)
dws.Name = DST_SHEET
' Assuming the 1st source or destination table:
Dim dlo As ListObject: Set dlo = dws.ListObjects(1)
dlo.Name = DST_TABLE
' Clear filters.
If dlo.ShowAutoFilter Then
If dlo.AutoFilter.FilterMode Then
dlo.AutoFilter.ShowAllData
End If
End If
' If nothing was filtered.
If lrg Is Nothing Then
dlo.DataBodyRange.Delete
MsgBox "Nothing to lookup.", vbExclamation
Exit Sub
End If
' Write the filtered strings to a dictionary.
Dim lDict As Object: Set lDict = CreateObject("Scripting.Dictionary")
lDict.CompareMode = vbTextCompare
Dim lCell As Range, lStr As String
For Each lCell In lrg.Cells
lStr = CStr(lCell.Value)
If Len(lStr) > 0 Then
If Not lDict.Exists(lStr) Then
lDict(lStr) = Empty
End If
End If
Next lCell
If lDict.Count = 0 Then
dlo.DataBodyRange.Delete
MsgBox "Only blanks found.", vbCritical
Exit Sub
End If
' Write the source or destination data to an array.
Dim drg As Range: Set drg = dlo.DataBodyRange
Dim dData(): dData = drg.Value
' Write the matching data to the top of the array.
Dim nUpper As Long: nUpper = UBound(dColumns)
Dim rCount As Long: rCount = UBound(dData, 1)
Dim cCount As Long: cCount = UBound(dData, 2)
Dim lKey, r As Long, dr As Long, c As Long, n As Long
Dim dStr As String, IsNotFound As Boolean
For r = 1 To rCount
For Each lKey In lDict.Keys
For n = 0 To nUpper
c = dColumns(n)
dStr = dData(r, c)
If StrComp(dStr, lKey, vbTextCompare) = 0 Then
Exit For
End If
Next n
If n > nUpper Then
IsNotFound = True
Exit For
End If
Next lKey
If IsNotFound Then
IsNotFound = False
Else
dr = dr + 1
For c = 1 To cCount
dData(dr, c) = dData(r, c)
Next c
End If
Next r
If dr = 0 Then
dlo.DataBodyRange.Delete
MsgBox "No matches found.", vbExclamation
Exit Sub
End If
' Write the matching data from the top of the array
' to the destination table.
drg.Resize(dr, cCount).Value = dData
' Delete the remaining (table) rows.
If dr < rCount Then
drg.Resize(rCount - dr).Offset(dr).Delete xlShiftUp
End If
' Inform.
MsgBox "Filtered data retrieved.", vbInformation
End Sub
答案2
得分: 1
Here is the translated code:
步骤一：在一个子过程中
'声明变量
Option Explicit
Private Sub doTheCopy()
Dim datat As ListObject, vis As Range, ar As Range, tar As Range
Dim statWs As Worksheet, dataWS As Worksheet
Dim lbr As Long, ubr As Long, lbc As Long, ubc As Long, rr As Long, cc As Long, fcnt As Integer, haveToFind As Integer
Dim arr() As Variant, ln() As String, filterdStr As String, strRowsToCopy As String
Const char160 = " "
'查找可见区域
Set vis = Me.ListObjects("ItemsTable").DataBodyRange.SpecialCells(xlCellTypeVisible)
If vis Is Nothing Then Exit Sub
'获取另外两个工作表
On Error Resume Next
Set dataWS = Worksheets("Data")
Set statWs = Worksheets("Stats")
If dataWS Is Nothing Then GoTo Lexit
Err.Clear
'如果“Stats”工作表不存在 => 创建它
If statWs Is Nothing Then
Set statWs = Worksheets.Add(, dataWS)
If statWs Is Nothing Then MsgBox ("无法创建“Stats”工作表"): GoTo Lexit
statWs.Name = "Stats"
End If
'从这一点开始，不需要继续错误处理
Err.Clear
On Error GoTo Lexit
'获取DataTable
Set datat = Worksheets("Data").ListObjects("DataTable")
'将表定位到Stat工作表以便复制表 => "A1"
Set ar = statWs.Range("A1")
'复制表并命名它 - 清除表内容以准备复制 - 如果不存在
If ar.ListObject Is Nothing Then
datat.Range.Copy ar
ar.ListObject.Name = "StatTable"
End If
If Not ar.ListObject.DataBodyRange Is Nothing Then
ar.ListObject.DataBodyRange.Delete
End If
'创建包含要查找的值的字符串，并计数它们
filterdStr = char160
For Each tar In vis
For cc = 1 To tar.CountLarge
If tar(cc) <> vbNullString Then
filterdStr = filterdStr & tar(cc) & char160
haveToFind = haveToFind + 1
End If
Next
Next
'逐行扫描表，如果有-haveToFind-匹配，则在字符串中添加行号
arr() = datat.DataBodyRange
ubr = UBound(arr, 1): lbr = LBound(arr, 1)
ubc = UBound(arr, 2): lbc = LBound(arr, 2)
For rr = lbr To ubr
fcnt = 0
For cc = lbc To ubc
If arr(rr, cc) <> vbNullString Then
If InStr(1, filterdStr, char160 & arr(rr, cc) & char160) > 0 Then fcnt = fcnt + 1
If fcnt = haveToFind Then
strRowsToCopy = strRowsToCopy & IIf(strRowsToCopy = vbNullString, "", " ") & rr
GoTo LnextRow
End If
End If
Next
LnextRow:
Next
'如果有要复制的行
If strRowsToCopy <> vbNullString Then
'拆分以获取行号
ln = Split(strRowsToCopy)
fcnt = 1
'从源表复制行到目标表
ubr = UBound(ln)
For cc = LBound(ln) To ubr
rr = Val(ln(cc))
ar.ListObject.ListRows.Add
datat.ListRows(rr).Range.Copy ar.ListObject.ListRows(fcnt).Range
fcnt = fcnt + 1
Next
End If
Lexit:
If Err.Number > 0 Then
MsgBox ("doTheCopy>" & vbCrLf & Err.Description & vbCrLf & "错误编号> " & Err.Number)
End If
On Error GoTo 0
End Sub
Private Sub BT_FILTER_ITEMS_Click()
Call doTheCopy
End Sub
**第二个修改后的版本，使用精确搜索，查找以“Item”开头的列标题**
Option Explicit
'参数
' exact > 用于精确搜索（True）或非精确搜索（False）
' copyAtCell > 在任何工作表中的位置（单元格）创建统计表
' 可选参数 lookHeadersStartWith > 查看以“Item”（默认）或任何其他字符串开头的列。比较不区分大小写（在比较中去除空格）
Private Sub doTheCopy(exact As Boolean, copyAtCell As Range, Optional lookHeadersStartWith As String = "ITEM")
Dim datat As ListObject, vis As Range, tar As Range
Dim statWs As Worksheet, dataWS As Worksheet, statTbl As ListObject, lr As ListRow
Dim lbr As Long, ubr As Long, lbc As Long, ubc As Long, rr As Long, cc As Long, fcnt As Integer, haveToFind As Integer
Dim arr() As Variant, hdr() As Variant, ln() As String, filterdStr As String, strRowsToCopy As String
Const char160 = " "
If copyAtCell.CountLarge > 1 Then Set copyAtCell = copyAtCell.Cells(1, 1)
'查找可见区域
Set vis = Me.ListObjects("ItemsTable").DataBodyRange.SpecialCells(xlCellTypeVisible)
If vis Is Nothing Then Exit Sub
'获取另外两个工作表
On Error Resume Next
Set dataWS = Worksheets("Data")
Set statWs = Worksheets("Stats")
If dataWS Is Nothing Then GoTo Lexit
Err.Clear
'如果“Stats”工作表不存在 => 创建它
If statWs Is Nothing Then
Set statWs = Worksheets.Add(, dataWS)
If statWs Is Nothing Then MsgBox ("无法创建“Stats”工作表"): GoTo Lexit
statWs.Name = "Stats"
End If
'从这一点开始，不需要继续错误处理
Err.Clear
On Error GoTo Lexit
'获取DataTable
Set datat = Worksheets("Data").ListObjects("DataTable")
'将表定位到Stat工作表以便复制表 => "A1"
'如果在位置（copy
<details>
<summary>英文:</summary>
STEP BY STEP in one sub
Option Explicit
Private Sub doTheCopy()
Dim datat As ListObject, vis As Range, ar As Range, tar As Range
Dim statWs As Worksheet, dataWS As Worksheet
Dim lbr As Long, ubr As Long, lbc As Long, ubc As Long, rr As Long, cc As Long, fcnt As Integer, haveToFind As Integer
Dim arr() As Variant, ln() As String, filterdStr As String, strRowsToCopy As String
Const char160 = " "
'FIND THE VISIBLE AREA
Set vis = Me.ListObjects("ItemsTable").DataBodyRange.SpecialCells(xlCellTypeVisible)
If vis Is Nothing Then Exit Sub
'GET THE TWO OTHER SHEETS
On Error Resume Next
Set dataWS = Worksheets("Data")
Set statWs = Worksheets("Stats")
If dataWS Is Nothing Then GoTo Lexit
Err.Clear
'IF STATS SHEET DON'T EXIST => CREATE IT
If statWs Is Nothing Then
Set statWs = Worksheets.Add(, dataWS)
If statWs Is Nothing Then MsgBox ("Can't create Stats Sheet"): GoTo Lexit
statWs.Name = "Stats"
End If
'AFTER THIS POINT I DONT NEED RESUME NEXT
Err.Clear
On Error GoTo Lexit
'GET DataTable
Set datat = Worksheets("Data").ListObjects("DataTable")
'POSITION IN STAT SHEET TO COPY THE TABLE => "A1"
Set ar = statWs.Range("A1")
'COPY THE TABLE AND NAME IT - CLEAR TABLE CONTENTS TO BE READY FOR COPY - IF NOT EXIST
If ar.ListObject Is Nothing Then
datat.Range.Copy ar
ar.ListObject.Name = "StatTable"
End If
if Not ar.ListObject.DataBodyRange is Nothing Then
ar.ListObject.DataBodyRange.Delete
End If
'MAKE A STRING WITH VALUES TO FIND, COUNT THEM
filterdStr = char160
For Each tar In vis
For cc = 1 To tar.CountLarge
If tar(cc) <> vbNullString Then
filterdStr = filterdStr & tar(cc) & char160
haveToFind = haveToFind + 1
End If
Next
Next
'SCAN LINE BY LINE THE TABLE AND IF TAKE -haveToFind- MATCHES THEN
'ADD THE LINE NUMBER IN STRING
arr() = datat.DataBodyRange
ubr = UBound(arr, 1): lbr = LBound(arr, 1)
ubc = UBound(arr, 2): lbc = LBound(arr, 2)
For rr = lbr To ubr
fcnt = 0
For cc = lbc To ubc
If arr(rr, cc) <> vbNullString Then
If InStr(1, filterdStr, char160 & arr(rr, cc) & char160) > 0 Then fcnt = fcnt + 1
If fcnt = haveToFind Then
strRowsToCopy = strRowsToCopy & IIf(strRowsToCopy = vbNullString, "", " ") & rr
GoTo LnextRow
End If
End If
Next
LnextRow:
Next
'IF HAVE LINES TO COPY
If strRowsToCopy <> vbNullString Then
'SPLIT TO TAKE THE LINE NUMBERS
ln = Split(strRowsToCopy)
fcnt = 1
'COPY THE LINES FROM SOURCE TABLE TO DESTINATION
ubr = UBound(ln)
For cc = LBound(ln) To ubr
rr = Val(ln(cc))
ar.ListObject.ListRows.Add
datat.ListRows(rr).Range.Copy ar.ListObject.ListRows(fcnt).Range
fcnt = fcnt + 1
Next
End If
Lexit:
If Err.Number > 0 Then
MsgBox ("doTheCopy>" & vbCrLf & Err.Description & vbCrLf & "error number> " & Err.Number)
End If
On Error GoTo 0
End Sub
Private Sub BT_FILTER_ITEMS_Click()
Call doTheCopy
End Sub
**SECOND modified VERSION WITH EXACT SEARCH
and look in colums whose headers begin with**
Option Explicit
'*****************PARAMETERS**************************************
' exact> for exact search (true) else (false)
' copyAtCell> the position (a cell) in any sheet to create the stat table
' Optional lookHeadersStartWith> look at columns whose headings
' begin with "Item" (default) or any other string.
' The comparison is case insensitive (in the comparison spaces are cut off)
'*****************************************************************
Private Sub doTheCopy(exact As Boolean, copyAtCell As Range, Optional lookHeadersStartWith As String = "ITEM")
Dim datat As ListObject, vis As Range, tar As Range
Dim statWs As Worksheet, dataWS As Worksheet, statTbl As ListObject, lr As ListRow
Dim lbr As Long, ubr As Long, lbc As Long, ubc As Long, rr As Long, cc As Long, fcnt As Integer, haveToFind As Integer
Dim arr() As Variant, hdr() As Variant, ln() As String, filterdStr As String, strRowsToCopy As String
Const char160 = " "
If copyAtCell.CountLarge > 1 Then Set copyAtCell = copyAtCell.Cells(1, 1)
'FIND THE VISIBLE AREA
Set vis = Me.ListObjects("ItemsTable").DataBodyRange.SpecialCells(xlCellTypeVisible)
If vis Is Nothing Then Exit Sub
'GET THE TWO OTHER SHEETS
On Error Resume Next
Set dataWS = Worksheets("Data")
Set statWs = Worksheets("Stats")
If dataWS Is Nothing Then GoTo Lexit
Err.Clear
'IF STATS SHEET DON'T EXIST => CREATE IT
If statWs Is Nothing Then
Set statWs = Worksheets.Add(, dataWS)
If statWs Is Nothing Then MsgBox ("Can't create Stats Sheet"): GoTo Lexit
statWs.Name = "Stats"
End If
'AFTER THIS POINT I DONT NEED RESUME NEXT
Err.Clear
On Error GoTo Lexit
'GET DataTable
Set datat = Worksheets("Data").ListObjects("DataTable")
'POSITION IN STAT SHEET TO create stats table => copyAtCell
'if in position (copyAtCell) exist any table delete it
If Not copyAtCell.ListObject Is Nothing Then
copyAtCell.ListObject.Delete
End If
'create new table at position (copyAtCell) with equal number of columns
Set statTbl = copyAtCell.Worksheet.ListObjects.Add(xlSrcRange, copyAtCell.Resize(1, datat.DataBodyRange.Columns.Count), , xlYes)
'can now give it a name for further reference
statTbl.Name = "STAT_TABLE"
'copy headers from DataTable
datat.HeaderRowRange.Copy copyAtCell
'MAKE A STRING WITH VALUES TO FIND, COUNT THEM
filterdStr = char160
For Each tar In vis
For cc = 1 To tar.CountLarge
If tar(cc) <> vbNullString Then
filterdStr = filterdStr & tar(cc) & char160
haveToFind = haveToFind + 1
End If
Next
Next
'SCAN LINE BY LINE THE TABLE AND IF TAKE >= -haveToFind- MATCHES THEN
'ADD THE LINE NUMBER IN STRING
arr() = datat.DataBodyRange
hdr() = datat.HeaderRowRange
ubr = UBound(arr, 1): lbr = LBound(arr, 1)
ubc = UBound(arr, 2): lbc = LBound(arr, 2)
For rr = lbr To ubr
fcnt = 0
For cc = lbc To ubc
If arr(rr, cc) <> vbNullString And InStr(1, UCase(Trim(hdr(1, cc))), lookHeadersStartWith) = 1 Then
If InStr(1, filterdStr, char160 & arr(rr, cc) & char160) > 0 Then
fcnt = fcnt + 1
Else
If exact Then GoTo LnextRow
End If
If fcnt = haveToFind And exact = False Then
GoTo LfoundOneRow
End If
End If
Next
If exact = True And fcnt >= haveToFind Then
LfoundOneRow:
strRowsToCopy = strRowsToCopy & IIf(strRowsToCopy = vbNullString, "", " ") & rr
End If
LnextRow:
Next
'IF HAVE LINES TO COPY
If strRowsToCopy <> vbNullString Then
'SPLIT TO TAKE THE LINE NUMBERS
ln = Split(strRowsToCopy)
fcnt = 1
'COPY THE LINES FROM SOURCE TABLE TO DESTINATION
ubr = UBound(ln)
For cc = LBound(ln) To ubr
rr = Val(ln(cc))
'If statTbl.ListRows.Count < fcnt Then
Set lr = statTbl.ListRows.Add
'End If
datat.ListRows(rr).Range.Copy lr.Range 'statTbl.ListRows(fcnt).Range
fcnt = fcnt + 1
Next
End If
Lexit:
If Err.Number > 0 Then
MsgBox ("doTheCopy>" & vbCrLf & Err.Description & vbCrLf & "error number> " & Err.Number)
End If
On Error GoTo 0
End Sub
Private Sub BT_FILTER_ITEMS_Click()
Call doTheCopy(Me.ExactSearch.value, Worksheets("Stats").Range("A1"))
End Sub
</details>
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库，让每个人都能够通过互相帮助和分享经验来进步。
评论