4

緯度と経度を入力したユーザーに最も近い気象観測所を計算する、大量のデータ (気象観測所のディレクトリ) を含むスプレッドシートがあります。このワークシートは、入力されたポイントからの距離を計算し、SMALL() を使用してそれらの距離をランク付けし、数式を含む Excel のテーブル/リストがランキングを使用して Index(Match()) タイプの計算を実行することによってこれを実現します (1 が最も近い、2 が 2 番目に近いなど)。 .

ワークシートは遅いですが、かなりうまく機能します。また、Excel テーブルを使用すると、さまざまな基準 (年単位の記録の長さなど) によって気象観測所のディレクトリを高度に並べ替えることができます。

私が書いていた VBA マクロは以前は機能していましたが、修正しようとすると機能しなくなりました (素晴らしい)。

VBA マクロの目的は、緯度/経度/気象ステーション名を使用して Google Earth KML ファイルを作成し、そのファイルを Google Earth に起動して、ユーザーが設定されたサイトの場所 (以前に入力した場所) 周辺の最寄りのステーションを視覚化できるようにすることです。ユーザーによって）。

残念ながら、私が使用した元の方法では、リストのフィルター処理された結果を処理できませんでした。ユーザーが結果をフィルター処理した場合 (たとえば、最初の 4 つの気象観測所が除外された場合)、マクロは最初の 4 つの気象観測所を書き込みます。表示されていない/フィルター処理されていませんでした。

フィルター可能なテーブルを持つ 4 つのワークシートに対して、異なるデータ型に対して 1 つのマクロのみを使用したいので、私にとっての問題はより困難になります。

この段階で、マクロが必要とするデータは、異なるワークシートの {"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
4

2 に答える 2

14

フィルター処理されたテーブルに対する反復の例を次に示します。これは、テーブルのようListObjectに配置された自動フィルター処理されたセルの範囲よりも操作が少し簡単なテーブルを使用しますが、同じ一般的な考え方を使用できます (非テーブルの を呼び出すことはできません)。DataBodyRangeListObject

テーブルを作成します。

フィルタリングされていないテーブル

それにいくつかのフィルターを適用します。

フィルタリングされたテーブル

いくつかの行が非表示になっていることに注意してください。表示されている行は必ずしも連続しているわけではないため.Areas、表のDataBodyRangewhich is 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

この方法を問題に合わせて調整してみてください。実装に特定のエラー/問題がある場合は、お知らせください。
元の質問を更新して、より具体的な問題を示すことを忘れないでください:)

于 2013-10-10T01:39:32.913 に答える
0

フィルタリングされたデータでレコードを見つけて、1 つの値を変更する必要がありました サンプル データ

営業担当者コードを顧客 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

ここに画像の説明を入力

于 2016-02-19T16:56:42.393 に答える