Excel VBAmacros – 通过过滤表的列循环
我有一个包含大量数据（气象站的目录）的电子表格，它计算用户input纬度和经度的最近气象站。 这个工作表通过计算与input点的距离，使用SMALL（）sorting这些距离，然后使用排名（1是最接近的，2是第二接近的等等） 。
工作表虽然很慢，工作得很好 – 而Excel表允许按照各种标准（例如年限等的logging长度）对气象站目录进行高级分类。
我有一个曾经工作过的VBAmacros，但是当我试图修复它（真棒）时停止工作。
VBAmacros的目的是编写一个带有纬度/经度/气象站名称的Google Earth KML文件，然后将该文件启动到谷歌地球上，以便用户可以将设置的站点位置周围的邻近站点（先前input的站点由用户）。
不幸的是，我使用的原始方法无法处理列表的过滤结果，因此如果用户过滤了结果（例如，前4个气象站被过滤掉），macros仍然会写入前四个气象站这是不可见/被过滤。
对于我来说，问题变得更加困难，因为我希望只有一个具有可筛选表格的工作表的macros – 针对不同的数据types。
在这个阶段，macros需要的数据在不同的工作表中以相同名称的表列存储在表中：{“STATION”，“LONGITUDE”，“LATITUDE”}。 写入KML文件所需的大部分KMLstring都存储在另一个隐藏工作表“KML”中。
macros是通过每个页面上的button启动的。
我知道可以使用“.SpecialCells（xlCellTypeVisible）”来解决这个问题 – 我已经尝试了很多方法来处理我的表 – 但是到目前为止还没有运气 – 可能是因为我缺乏正式的培训。
任何帮助表示赞赏，无论是解决scheme或build议！ 对于我错误的代码抱歉，问题循环和破碎的代码区域大约是一半 – 在“在活动工作表上查找所有表格：
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 这是一个迭代过滤表的例子。 这使用了一个ListObject表，它比一个像表一样排列的自动过滤单元格的范围稍微容易一些，但是可以使用相同的总体思路（除非你不能调用非ListObject表的DataBodyRange ） 。
创build一个表格：
应用一些filter（S）：
请注意，有几行已被隐藏，可见行不一定是连续的，所以我们需要使用表的DataBodyRange的DataBodyRange ，它们是可见的 。
正如你已经猜测，你可以使用.SpecialCells(xlCellTypeVisible)来做到这一点。
这是一个例子：
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
示例输出：
Filtered table: $A$2:$G$2,$A$4:$G$4,$A$6:$G$6,$A$9:$G$10 Area: $A$2:$G$2 Row: $A$2:$G$2 Area: $A$4:$G$4 Row: $A$4:$G$4 Area: $A$6:$G$6 Row: $A$6:$G$6 Area: $A$9:$G$10 Row: $A$9:$G$9 Row: $A$10:$G$10
尝试和适应你的问题，如果你有一个具体的错误/执行它的问题，让我知道。
只记得更新你的原始问题，以表明一个更具体的问题:)
我必须在筛选的数据中findlogging并更改一个值样本数据
我想要将销售人员密码更改为客户C00005。
首先我过滤，发现客户修改。
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
在这里input图像描述