Excel VBA宏循环遍历筛选表的列
我有一个包含一大堆数据的电子表格(气象站目录)，它可以计算距离用户输入纬度和经度最近的气象站。此工作表通过计算距输入点的距离，使用SMALL()对这些距离进行排名，然后使用公式的excel表格/列表使用排名执行Index(Match())类型的计算(1表示最近，2表示第二接近，等等)来实现这一点。
工作表虽然很慢，但工作得相当好- excel表格允许根据各种标准(如记录的年限等)对气象站目录进行高级排序。
我有一个我正在写的VBA宏，它曾经可以工作，但当我试图修复它时，它停止了工作(太棒了)。
VBA宏的目的是使用经度/经度/气象站名称编写Google Earth KML文件，然后将该文件启动到google earth中，以便用户可以可视化设置的站点位置(用户先前输入的位置)周围的邻近站点。
不幸的是，我使用的原始方法不能处理列表的过滤结果，因此如果用户过滤了结果(例如，前4个气象站被过滤掉了)，宏仍然会写出不可见的前4个气象站/被过滤的前4个气象站。
对于我来说，问题变得更加困难，因为我希望四个工作表只有一个宏，这些工作表具有可筛选的表-用于不同的数据类型。
在此阶段，宏所需的数据存储在不同工作表中同名表列的表中：{"STATION"，“LATITUDE”，"LATITUDE"}。写入KML文件所需的大多数KML字符串都存储在另一个隐藏工作表"KML“中。
宏通过每个页面上的按钮启动。
我知道可能会有一个使用".SpecialCells(xlCellTypeVisible)“的解决方案-我已经广泛地尝试让它与我的表一起工作-但到目前为止还没有成功-可能是因为我缺乏正式的培训。
感谢任何帮助，无论是解决方案还是建议！为我的错误代码道歉，问题循环和损坏的代码区大约在半路上-在活动工作表上查找所有表之后：
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 回答 2
Stack Overflow用户
发布于 2013-10-10 09:39:33
下面是一个对过滤表进行迭代的示例。这使用了一个ListObject表，它比像表一样排列的一系列自动筛选的单元格更容易使用，但也可以使用相同的一般概念(除了不能调用非ListObject表的DataBodyRange )。
创建一个表：
对其应用一些过滤器：
注意，有几行已经被隐藏，并且可见的行不一定是连续的，因此我们需要使用表的DataBodyRange的.Areas，它们是 visible 。
正如您已经猜测的那样，您可以使用.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尝试将此方法应用于您的问题，如果您在实现它时遇到特定的错误/问题，请让我知道。
只需记住更新您的原始问题，以指出更具体的问题:)
Stack Overflow用户
发布于 2016-02-20 00:56:42
我必须在过滤后的数据中找到一条记录，并更改一个值Sample data
我想将销售人员代码更改为customer 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 Ifenter image description here
https://stackoverflow.com/questions/19284913
复制相似问题
腾讯云开发者
