Excel VBA宏 - 通過過濾表的列循環

Question

我有一個電子表格，包含大量數據（氣象站的目錄），它可以計算用戶輸入緯度和經度的最近氣象站。這個工作表通過計算距輸入點的距離，使用SMALL（）對這些距離進行排序，然後使用排名（1是最接近的，2是第二接近的等），然後是具有公式的Excel表/列表執行Index（Match 。

工作表雖然很慢，工作得很好 - 而且Excel表允許按照各種標準（如年限等記錄的長度）對氣象站目錄進行高級排序。

我有一個VBA宏，我正在寫它曾經工作，但停止工作，當我試圖修復它（真棒）。

VBA宏的目的是編寫經緯度/氣象站名稱的Google地球KML文件，然後將該文件啓動到谷歌地球，以便用戶可以在設置的站點位置周圍可視化鄰近站點（之前由用戶輸入的那個）。

不幸的是，我使用的原始方法無法處理列表的過濾結果，例如，如果用戶過濾了結果（例如，前4個氣象站被過濾掉的例子），宏仍然會寫前四個不可見/被過濾的氣象站。

對我來說問題變得更加困難，因爲我希望只有一個具有可篩選表格的工作表的宏 - 針對不同的數據類型。

在這個階段，宏需要的數據存儲在不同工作表中的名稱相同的表列中：{「STATION」，「LONGITUDE」，「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 

Answer 1

這裏是迭代在過濾表的例子。這使用了一張ListObject表格，它比僅僅使用類似於表格的一系列自動過濾單元更容易處理，但可以使用相同的總體思路（除非您不能撥打非ListObject的DataBodyRange表）。

創建一個表：

應用一些過濾器（S）到它：

注意，幾排已經被隱藏，可見行不一定因此我們需要使用表DataBodyRange的.Areas，它們是可見。

正如你已經猜測，你可以使用.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 

嘗試並適應這個方法將你的問題，如果你有實現它特定的錯誤/問題，讓我知道。
只記得更新你原來的問題，表示更具體的問題:)

Answer 2

我必須找到一個記錄在經過濾的數據和更改一個值 Sample data

我想改變銷售personcode客戶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 

enter image description here