Excel VBA Macro – Looping dans une colonne d'une table filtrée

J'ai une feuille de calcul avec un tas de données (un directory des stations météorologiques) qui calcule les stations météorologiques les plus proches vers un user saisi Latitude et Longitude. Cette feuille de travail la réalise en calculant la distance à partir du point entré, en classant ces distances à l'aide de SMALL () puis d'un Excel TABLE / List avec des formules effectuant des calculs de type Index (Match ()) à l'aide de Rankings (1 est le plus proche, 2 est le deuxième plus proche, etc.) .

La feuille de travail est lente, elle fonctionne assez bien – et les tables excel permettent un sorting avancé du directory de la station météorologique selon différents critères (comme la durée de l'logging en années, etc.).

J'ai une macro VBA que j'écrivais qui travaillait, mais je cessais de fonctionner quand j'ai essayé de la résoudre (génial).

Le but de la macro VBA est d'écrire un file KML Google Earth avec le nom lat / long / station météorologique, puis de lancer ce file sur google earth afin que l'user puisse visualiser les stations proches autour d'un location de site défini (celui précédemment entré par l'user).

Malheureusement, la méthode d'origine que j'ai utilisée ne pouvait pas gérer les résultats filtrés de la list, de sorte que si l'user a filtré les résultats (de sorte que les 4 premières stations météorologiques ont été filtrées par exemple), la macro écrirait encore les quatre premières stations météorologiques qui n'étaient pas visibles / ont été filtrés.

Le problème pour moi est plus difficile car je souhaite avoir une seule macro pour quatre feuilles de calcul avec des tables filtrantes – pour différents types de données.

À ce stade, datatables requirejses par les macro sont stockées dans les arrays dans des colonnes de table identiques: {"STATION", "LONGITUDE", "LATITUDE"} dans différentes feuilles de calcul. La majorité des strings KML requirejses pour écrire dans le file KML sont stockées dans une autre feuille cachée "KML".

La macro est lancée via un button sur chacune de ces pages.

Je comprends qu'il pourrait y avoir une solution en utilisant ".SpecialCells (xlCellTypeVisible)" – et j'ai beaucoup essayé de l'utiliser pour mes tables – mais je n'ai eu aucune chance jusqu'à présent – probablement en raison de mon manque de formation formelle.

Toute aide appréciée, que ce soit une solution ou une suggestion! Je m'excuse pour mon mauvais code, la boucle du problème et la zone de code brisée est à peu près à mi-path – après «Trouver tout le tableau sur la feuille active:

Sub KML_writer() Dim FileName As Ssortingng Dim StrA As Ssortingng 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 Ssortingngs 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 ssortingngs 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

Voici un exemple d'itération sur une table filtrée. Cela utilise une table ListObject qui est un peu plus facile à utiliser que juste une gamme de cellules autofiltrées disposées comme une table, mais la même idée générale peut être utilisée (sauf que vous ne pouvez pas appeler DataBodyRange d'une table non ListObject ) .

Créer une table:

Table non filtrée

Appliquez-lui un filter (s):

Table filtrée

Notez que plusieurs lignes ont été cachées et que les lignes visibles ne sont pas forcément contiguës. Nous devons donc utiliser les .Areas du .Areas de la table qui sont visibles .

Comme vous l'avez déjà supposé, vous pouvez utiliser .SpecialCells(xlCellTypeVisible) pour ce faire.

Voici un exemple:

 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

Exemple de sortie:

 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

Essayez et adaptez cette méthode à votre problème, et si vous avez une erreur / problème spécifique lors de la mise en œuvre, faites-le moi savoir.
N'oubliez pas de mettre à jour votre question initiale pour indiquer un problème plus spécifique 🙂

Je devais find un logging dans une donnée filtrée et modifier une valeur Exemples de données

Je voulais changer le code de la personne de vente au client C00005.

D'abord, j'ai filtré et trouvé le client à modifier.

 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

entrez la description de l'image ici