Kategorie szkoleń | Egzaminy | Kontakt
  • 1
  • 0
  • 1

Witam,
Potrzebuję pomocy przy napisaniu makra kopiującego wiersze pomiędzy arkuszami jeśli data i godzina w pierwszej kolumnie jest taka sama lub z najmniejszą różnicą czasu (sekundy).
Zakres kopiowanych wierszy będzie modyfikowany ale z tym może sobie poradzę.

Z góry dziękuję za pomoc

Załączniki

  • xlsm

    lepkość-część kopiowanie ... ( 6M )
Piotr_Rzemień
  • Zapytał
  • @ Piotr_Rzemień | 09.11.2020
    • 1
    • 0
    • 0
Zaloguj się aby zadać pytanie
Pokrewne

Odpowiedź (1)

  • 0

Sprawdź poniższe makro. Dane są z dokładnością do milisekund i nie jestem do końca pewny, czy wyniki poprawnie się przypisują.

Sub znajdz()
Dim czujnik As Worksheet, robot As Worksheet, tmr&, rc&, rr&, i&, szukaj As Date

' startuję stoper
tmr = Timer

' przypisuję arkusze do zmiennych
Set czujnik = ThisWorkbook.Worksheets("czujnik")
Set robot = ThisWorkbook.Worksheets("robot")

' sortuję oba arkusze po czasie - ważne!
With czujnik.ListObjects("Tabela1").Sort
   With .SortFields
      .Clear
      .Add2 Key:=Range("Tabela1[[#Headers],[czas]]"), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
   End With
    .Header = xlYes
    .Apply
End With

With robot.ListObjects("Tabela2").Sort
   With .SortFields
      .Clear
      .Add2 Key:=Range("Tabela2[[#Headers],[Date and Time]]"), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
   End With
   .Header = xlYes
   .Apply
End With

' ustawiam zmienne z wierszami startowymi oraz licznik znalezionych
rc = 2
rr = 2
i = 0

' rozpoczynam pętlę od drugiej do ostatniej niepustej komórki
' w kolumnie A na arkuszu 'czujnik'
Do While czujnik.Cells(rc, 1) <> ""
   ' ustawiam szukaną zmienną
   szukaj = czujnik.Cells(rc, 1).Value2 - TimeValue("0:0:1")
   
   ' pętla przeszukująca arkusz 'robot'
   Do While robot.Cells(rr, 1).Value2 < szukaj
      rr = rr + 1
      ' warunek kończący makro na wypadek, gdyby na arkuszu 'czujnik'
      ' były nowsze daty, niż w 'robocie'
      If robot.Cells(rr, 1).Value2 = "" Then
         MsgBox "Koniec danych na arkuszu 'robot', wyszukiwanie przerwane.", vbExclamation
         Exit Sub
      End If
   Loop
   
   ' sprawdzam, czy znaleziona godzina mieści się w przedziale +/- 1s
   If DateDiff("s", szukaj, robot.Cells(rr, 1).Value2) <= 2 Then
      ' przepisuję wartości do arkusza 'czujnik'
      czujnik.Cells(rc, 5).Resize(1, 4).Value2 = robot.Cells(rr, 1).Resize(1, 4).Value2
      ' zwiększam liczniki wiersza arkusza 'robot' i znalezionych
      rr = rr + 1
      i = i + 1
   End If
   ' zwiększam licznik wiersza arkusza 'czujnik'
   rc = rc + 1
Loop

MsgBox "Znalazłem " & i & " dopasowań w czasie " & Round(Timer - tmr, 2) & " s.", vbInformation

End Sub

 Dodatkowo podrzucam rozwiązanie w Power Query, to zdecydowanie bardziej przyjazne narzędzie do takich zadań.

let
    Źródło = Excel.CurrentWorkbook(){[Name="Tabela1"]}[Content],
    #"Zmieniono typ" = Table.TransformColumnTypes(Źródło,{{"czas", type datetime}, {"zahn kubek pomiar", type any}, {"Viscosity [mPa.s]", type number}, {"Temperature [ーC]", type number}}),
    robot = Excel.CurrentWorkbook(){[Name="Tabela2"]}[Content],
    #"Zmieniono typ2" = Table.TransformColumnTypes(robot,{{"Date and Time", type datetime}, {"Part No:1", type text}, {"ac1.humidity", type number}, {"ac1.temp", type number}}),
    #"Scalone zapytania" = Table.NestedJoin(#"Zmieniono typ",{"czas"},#"Zmieniono typ2",{"Date and Time"},"robot",JoinKind.LeftOuter),
    #"Rozwinięty element robot" = Table.ExpandTableColumn(#"Scalone zapytania", "robot", {"Date and Time", "Part No:1", "ac1.humidity", "ac1.temp"}),
    #"Przefiltrowano wiersze" = Table.SelectRows(#"Rozwinięty element robot", each [Date and Time] = null),
    #"Usunięto kolumny" = Table.RemoveColumns(#"Przefiltrowano wiersze",{"Date and Time", "Part No:1", "ac1.humidity", "ac1.temp"}),
    #"Dodano kolumnę czas" = Table.AddColumn(#"Usunięto kolumny", "czas+-1", each {[czas]-#duration(0,0,0,1), [czas]+#duration(0,0,0,1)}),
    #"Rozwinięty element czas" = Table.ExpandListColumn(#"Dodano kolumnę czas", "czas+-1"),
    #"Scalone zapytania1" = Table.NestedJoin(#"Rozwinięty element czas",{"czas+-1"},#"Zmieniono typ2",{"Date and Time"},"robot",JoinKind.LeftOuter),
    #"Rozwinięty element robot1" = Table.ExpandTableColumn(#"Scalone zapytania1", "robot", {"Date and Time", "Part No:1", "ac1.humidity", "ac1.temp"}),
    #"Przefiltrowano puste" = Table.SelectRows(#"Rozwinięty element robot1", each [Date and Time] <> null and [Date and Time] <> ""),
    #"Usunięto kolumnę czas" = Table.RemoveColumns(#"Przefiltrowano puste",{"czas+-1"}),
    #"Dołączone zapytanie" = Table.Combine({#"Usunięto kolumnę czas", #"Rozwinięty element robot"}),
    #"Usunięto duplikaty" = Table.Distinct(#"Dołączone zapytanie", {"czas"}),
    #"Posortowano wiersze" = Table.Sort(#"Usunięto duplikaty",{{"czas", Order.Ascending}, {"Date and Time", Order.Ascending}})
in
    #"Posortowano wiersze"

 

Załączniki

  • xlsm

    lepkość-część kopiowanie.... ( 6M )
Mirosław_Janiak
  • Odpowiedział
  • @ Mirosław_Janiak | 30.12.2020
    • 1
    • 7
    • 1