Excel VBA 宏 - 循环过滤表的一列

Excel VBA Macro - Looping through a column of a filtered table

提问by user2864977

I have a spreadsheet with a whole bunch of data (A directory of weather stations) which calculates the closest weather stations to a user entered Latitude and Longitude. This worksheet achieves this by calculating distance from the entered point, ranking those distances using SMALL() and then an excel TABLE/List with formulas perform Index(Match()) type calculations using Rankings (1 is closest, 2 is 2nd closest etc).

我有一个包含大量数据（气象站目录）的电子表格，它计算离用户输入的纬度和经度最近的气象站。该工作表通过计算与输入点的距离来实现这一点，使用 SMALL() 对这些距离进行排名，然后使用公式执行 Index(Match()) 类型计算的 excel 表格/列表使用排名（1 是最近的，2 是第二最近的等） .

The worksheet whilst slow, works fairly well - and the excel Tables allow for advanced sorting of the weather station directory by various criteria (Such as length of record in years etc).

工作表虽然很慢，但工作得相当好 - excel 表格允许按各种标准（例如记录长度（以年为单位）等）对气象站目录进行高级排序。

I have a VBA Macro that I was writing which used to work, but stopped working when I tried to fix it (awesome).

我有一个我正在编写的 VBA 宏，它曾经可以工作，但是当我尝试修复它时停止工作（很棒）。

The purpose of the VBA Macro is to write a Google Earth KML file with the lat/long/weather station name and then to launch that file into google earth so the user can visualise the proximate stations around a set site location (the one previously entered by the user).

VBA 宏的目的是编写一个带有纬度/经度/气象站名称的 Google 地球 KML 文件，然后将该文件启动到 Google 地球中，以便用户可以在设置的站点位置（之前输入的位置）周围可视化邻近的站点由用户）。

Unfortunately the original method I used couldn't handle the Filtered Results of the List, such that if the user filtered the results (Such that the first 4 weather stations were filtered out as an example) the macro would still write the first four weather stations that were not Visible/Were Filtered.

不幸的是，我使用的原始方法无法处理列表的过滤结果，因此如果用户过滤结果（例如过滤掉前 4 个气象站），宏仍然会写入前四个气象站不可见/被过滤的。

The problem for me is made more difficult as I wish to have only one macro for four worksheets with filter-able tables - for different data types.

对我来说，这个问题变得更加困难，因为我希望只有一个宏可以用于具有可过滤表的四个工作表 - 用于不同的数据类型。

At this stage the data the macro needs are stored in the Tables in identically named Table Columns: {"STATION","LONGITUDE","LATITUDE"} in different worksheets. The majority of the KML strings required to write to the KML file are stored in another hidden worksheet "KML".

在这个阶段，宏需要的数据存储在表中的同名表列中：{"STATION","LONGITUDE","LATITUDE"} 在不同的工作表中。写入 KML 文件所需的大部分 KML 字符串都存储在另一个隐藏的工作表“KML”中。

The macro is launched via a button on each of these pages.

宏通过每个页面上的按钮启动。

I understand that there could be a solution using ".SpecialCells(xlCellTypeVisible)" - and I've tried extensively to get it to work with my Tables - but have had no luck so far - probably due to my lack of formal training.

我知道可能有一个使用“.SpecialCells(xlCellTypeVisible)”的解决方案——我已经广泛尝试让它与我的表格一起工作——但到目前为止没有运气——可能是由于我缺乏正式培训。

Any help appreciated, be it a solution or a suggestion! Apologies for my bad code, the problem loop & broken code area is about halfway down - after 'Find all table on active sheet:

任何帮助表示赞赏，无论是解决方案还是建议！为我的错误代码道歉，问题循环和损坏的代码区域大约下降了一半 - 在“在活动工作表上查找所有表格之后：

Sub KML_writer()
Dim FileName As String
Dim StrA As String
Dim NumberOfKMLs
Dim MsgBoxResponse
Dim MsgBoxTitle
Dim MsgBoxPrompt
Dim WhileCounter
Dim oSh As Worksheet
    Set oSh = ActiveSheet
'Prompt the Number of Stations to Write to the KML File
NumberOfKMLs = InputBox(Prompt:="Please Enter the number of Weather Stations to generate within the Google Earth KML file", _
                Title:="Number of Weather Stations", Default:="10")
'Prompt a File Name
FileName = InputBox(Prompt:="Please Enter a name for your KML File.", _
                Title:="Lat Long to KML Converter", Default:="ENTER FILE NAME")

'Will clean this up to not require Write to Cell and Write to KML duplication later
Sheets("kml").Range("B3").Value = FileName
Sheets("mrg").Range("C5").Value = "Exported from EXCEL by AJK's MRG Function"

saveDir = "H:\" 'Local Drive available for all users of macro

targetfile = saveDir & FileName & ".KML"

'Write Site Location to KML STRING - user entered values from SITE LOCATION worksheet
StrA = Sheets("kml").Range("B1").Value & Sheets("kml").Range("B2").Value & "SITE LOCATION" & Sheets("kml").Range("B4").Value & Sheets("INPUT COORDINATES").Range("E5").Value & Sheets("kml").Range("B6").Value & Sheets("INPUT COORDINATES").Range("E4").Value & Sheets("kml").Range("B8").Value

    'Find all tables on active sheet
    Dim oLo As ListObject
    For Each oLo In oSh.ListObjects

'
        Dim lo As Excel.ListObject
        Dim lr As Excel.ListRow
        Set lo = oSh.ListObjects(oLo.Name)
        Dim cl As Range, rng As Range
        Set rng = Range(lo.ListRows(1))  'this is where it breaks currently

    For Each cl In rng2    '.SpecialCells(xlCellTypeVisible)


'Stop looping when NumberofKMLs is written to KML
            WhileCounter = 0
            Do Until WhileCounter > (NumberOfKMLs - 1)
            WhileCounter = WhileCounter + 1

                Dim St
                Dim La
                Dim Lon


                'Store the lr.Range'th station data to write to the KML
                St = Intersect(lr.Range, lo.ListColumns("STATION").Range).Value
                La = Intersect(lr.Range, lo.ListColumns("LATITUDE").Range).Value
                Lon = Intersect(lr.Range, lo.ListColumns("LONGITUDE").Range).Value


                'Write St La Long & KML Strings for Chosen Stations
                StrA = StrA & Sheets("kml").Range("B2").Value & St & Sheets("kml").Range("B4").Value & Lon & Sheets("kml").Range("B6").Value & La & Sheets("kml").Range("B8").Value

        Loop
        Next
        Next

'Write end of KML strings to KML File
StrA = StrA & Sheets("kml").Range("B9").Value

'Open, write, close KML file
Open targetfile For Output As #1
Print #1, StrA
Close #1

'Message Box for prompting the launch of the KML file
MsgBoxTitle = ("Launch KML?")
MsgBoxPrompt = "Would you like to launch the KML File saved at " & targetfile & "?" & vbCrLf & vbCrLf & "Selecting 'No' will not prevent the file from being written."
MsgBoxResponse = MsgBox(MsgBoxPrompt, vbYesNo, MsgBoxTitle)
If MsgBoxResponse = 6 Then ThisWorkbook.FollowHyperlink targetfile

End Sub 

回答by David Zemens

Here is an example of iteration over a filtered table. This uses a ListObjecttable which are a little easier to work with than just a range of autofiltered cells arranged likea table, but the same general idea can be used (except you can't call on the DataBodyRangeof a non-ListObjecttable).

这是对过滤表进行迭代的示例。这使用了一个ListObject表格，它比只是像表格一样排列的一系列自动过滤的单元格更容易使用，但可以使用相同的一般想法（除非您不能调用DataBodyRange非ListObject表格的 ）。

Create a table:

创建一个表：

Apply some filter(s) to it:

对其应用一些过滤器：

Notice that several rows have been hidden, and the visible rows are not necessarily contiguous, so we need to use the .Areasof the table's DataBodyRangewhich are visible.

请注意，几排已经被隐藏，可见行不一定是连续的，所以我们需要使用.Areas表的的DataBodyRange哪些是可见的。

As you've already surmised, you can use the .SpecialCells(xlCellTypeVisible)to do this.

正如您已经推测的那样，您可以使用.SpecialCells(xlCellTypeVisible)来执行此操作。

Here's an example:

下面是一个例子：

Sub TestFilteredTable()

   Dim tbl As ListObject
   Dim rngTable As Range
   Dim rngArea As Range
   Dim rngRow As Range

   Set tbl = ActiveSheet.ListObjects(1)
   Set rngTable = tbl.DataBodyRange.SpecialCells(xlCellTypeVisible)

   ' Here is the address of the table, filtered:
   Debug.Print "Filtered table: " & rngTable.Address

   '# Here is how you can iterate over all
   '  the areas in this filtered table:
   For Each rngArea In rngTable.Areas
      Debug.Print "  Area: " & rngArea.Address

         '# You will then have to iterate over the
         '  rows in every respective area
         For Each rngRow In rngArea.Rows
            Debug.Print "    Row: " & rngRow.Address
         Next
   Next

End Sub

Sample output:

示例输出：

Filtered table: $A:$G,$A:$G,$A:$G,$A:$G
  Area: $A:$G
    Row: $A:$G
  Area: $A:$G
    Row: $A:$G
  Area: $A:$G
    Row: $A:$G
  Area: $A:$G
    Row: $A:$G
    Row: $A:$G

Try and adapt this method to your problem, and if you have a specific error/issue with implementing it, let me know.
Just remember to update your original question to indicate a more specific problem :)

尝试并根据您的问题调整此方法，如果您在实施它时遇到特定错误/问题，请告诉我。
请记住更新您的原始问题以指出更具体的问题:)

回答by user2469312

I had to find a record in a filtered data and change one value Sample data

我必须在过滤后的数据中找到一条记录并更改一个值 示例数据

I wanted to change sales personcode to customer C00005.

我想将销售人员代码更改为客户 C00005。

First i filtered and found customer to modify.

首先我过滤并找到客户进行修改。

codcliente = "C00005"


enter  'make sure that this customer exist in the checked range


 Set test = CheckRng.Find(What:=codcliente, LookIn:=xlValues, LookAt:=xlWhole)
  If test Is Nothing Then
    MsgBox ("Does not exist customer  """ & codcliente & """ !")
    DataSheet.AutoFilterMode = False
  Else 'Customer Exists
    With DataRng 'filter the customer
        .AutoFilter Field:=1, Criteria1:=codcliente
    End With
   Set customer = DataRng.SpecialCells(xlCellTypeVisible) ′Get customer data. It is visible
   customer.Cells(1, 6).Value = "NN" 'navigate to 6th column and change code
End If

enter image description here

在此处输入图片说明