Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1896to1900
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

SPS Meldearchiv

SPS Meldearchiv
06.09.2022 15:43:04
Michael
Hallo zusammen,
ich tüftel gerade an einer Lösung für nachfolgendes Problem. Leider ist meine Lösung nicht funktionell, da es ewig dauert, bis die Schleifen durchgelaufen sind.
Folgendes Problem:
Ich habe eine Tabelle mit tausenden Meldungen einer SPS. Jede Meldung besteht aus zwei Einträgen, also zwei Zeilen: Das erste mal wenn die Meldung auftaucht, das zweite mal wenn die Meldung verschwindet. Dadurch bin ich in der Lage zu sagen, wie lange eine Meldung ansteht.
Ich möchte nun gerne aus diesen Rohdaten eine Tabelle erzeugen, in der jede Meldung nur ein einziges mal vorhanden ist und Startzeit und die Endzeit aufgeführt werden.
Anbei zur Veranschaulichung was ich meine. https://www.herber.de/bbs/user/155012.xlsx
Hier ist das was ich bisher geschrieben habe. Leider hängen die Schleifen ewig und die Einmaligkeit jeder einzelnen Meldung ist auch nicht gegeben.

Sub Vereinzeln()
Dim x, y As Long
Dim A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P As String
Dim Zeilen As Integer
Dim ID As Integer
Dim zeitkommend, zeitgehend, zeitdauer As Integer
Sheets("source").Activate
Zeilen = ActiveSheet.UsedRange.Rows.Count
For x = 2 To Zeilen
O = Cells(x, 15)
zeitkommend = Cells(x, 14)
ID = x
For y = x + 1 To Zeilen
If Cells(y, 15) = O Then
A = Cells(y, 1)
B = Cells(y, 2)
C = Cells(y, 3)
D = Cells(y, 4)
E = Cells(y, 5)
F = Cells(y, 6)
G = Cells(y, 7)
H = Cells(y, 8)
I = Cells(y, 9)
J = Cells(y, 10)
K = Cells(y, 11)
L = Cells(y, 12)
M = Cells(y, 13)
'N = Cells(y, 14)
'O = Cells(y, 15)
P = Cells(y, 16)
zeitgehend = Cells(y, 14)
'zeitdauer = zeitgehend - zeitkommend
Sheets("target").Activate
Cells(ID, 1) = A
Cells(ID, 2) = B
Cells(ID, 3) = C
Cells(ID, 4) = D
Cells(ID, 5) = E
Cells(ID, 6) = F
Cells(ID, 7) = G
Cells(ID, 8) = H
Cells(ID, 9) = I
Cells(ID, 10) = J
Cells(ID, 11) = K
Cells(ID, 12) = L
Cells(ID, 13) = M
Cells(ID, 14) = N
Cells(ID, 15) = O
Cells(ID, 16) = P
Cells(ID, 17) = zeitkommend
Cells(ID, 18) = zeitgehend
End If
Next
Next
End Sub

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: SPS Meldearchiv
06.09.2022 16:04:53
peterk
Hallo
Ich würde folgendes machen:

* Sortiere die Source Tabelle nach MsgNr und TimeString
* Schleife
x=2
Do
if cells(x,2)=Cells(x+1,2) then
' Meldung Start/Ende Zeile schreiben
x=x+2
else
' Meldung nur Start, trozdem Zeile schreiben, Ende fehlt!
x=x+1
end if
Loop until x>=Zeilen
* Sortiere die Traget Tabelle nach StartMeldung
Peter
AW: SPS Meldearchiv
06.09.2022 16:12:55
Daniel
Hi
den Ablauf kannst du dir doch mit Sortieren optimieren:
1. Sortiere nach Spalte MsgText und Zeit (TimeString der Time_ms
jetzt sollte die Liste nach Meldungen sortiert sein und immer öffnen und schließen für jede Meldung direkt untereinander stehen.
2. füge in die Liste jetzt zwei zusätzliche Spalten ein. in der ersten Spalte übernimmst du den TimeString aus der darunterliegenden Zeile (wenns die gleiche Meldung ist)
damit holst du dir den "geschlossen" Zeitwert in die Zeile mit dem "geöffnet" Zeitwert.
in der zweiten Zeile lässt du einfach einen Zähler hochlaufen, der den Vorgängerwert um 1 hochzählt, wenn "geöffnet" und die Meldung gleich der Vorgängerzeile ist, kommt eine neue Meldung, dann setzt du den Zähler auf 1 zurück
3. ersetze in den Hilfsspalten die Formel durch Werte
4. lösche alle Zeilen mit dem Kommentar "geschlossen"
5. sortiere wieder nach Zeit
das sollte, wenn man es richtig macht sehr schnell gehen.
Gruß Daniel
Anzeige
AW: SPS Meldearchiv
06.09.2022 18:20:58
Daniel
HI
probier mal diesen Code.
ggf noch Spaltenbreite anpassen damit die ### verschwinden und das Spaltentauschen überlasse ich auch noch dir

Sub test()
Sheets("Source").Copy after:=Sheets("Source")
With ActiveSheet.Cells(1, 1).CurrentRegion
.Sort key1:=.Cells(1, 15), order1:=xlAscending, key2:=.Cells(1, 14), order2:=xlAscending, Header:=xlYes
With .Cells(2, .Columns.Count + 1).Resize(.Rows.Count - 1, 3)
.Columns(1).FormulaR1C1 = "=IF(RC15=R[1]C15,R[1]C14,"""")"
.Columns(2).FormulaR1C1 = "=IF(RC15R[-1]C15,1,IF(right(RC16,1)=""n"",R[-1]C,R[-1]C+1))"
.Columns(3).FormulaR1C1 = "=RC15&"" No."" & RC[-1]"
.Formula = .Value
.Columns(1).NumberFormat = Cells(2, 14).NumberFormat
End With
End With
With ActiveSheet.Cells(1, 1).CurrentRegion
.Columns(16).Replace "*geschlossen", "", xlWhole
.Sort key1:=.Cells(1, 16), order1:=xlAscending, Header:=xlYes
.Columns(16).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Sort key1:=.Cells(1, 14), order1:=xlAscending, Header:=xlYes
.Cells(1, 14).Value = "Start Meldung"
.Cells(1, 17).Value = "Ende Meldung"
.Cells(1, 19).Value = "Kommentar"
.Columns(18).Delete
.Columns(16).Delete
.Columns(1).Resize(, 3).Delete
End With
End Sub
Gruß Daniel
Anzeige
AW: SPS Meldearchiv
06.09.2022 18:26:20
Nepumuk
Hallo Michael,
teste mal:

Option Explicit
Public Sub CompressData()
Const MSG_OPEN As String = "eröffnet"
Const MSG_CLOSE As String = "geschlossen"
Dim objOpen As Range, objClose As Range
Dim objDictionary As Object
Dim strFirstAddressOpen As String
Dim strMessage As String
Dim lngNextRow As Long
Application.ScreenUpdating = False
If Not Worksheets("target").ListObjects(1).DataBodyRange Is Nothing Then _
Call Worksheets("target").ListObjects(1).DataBodyRange.Delete
lngNextRow = 2
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
With Worksheets("source")
Set objOpen = .Columns(16).Find(What:=MSG_OPEN, After:=.Cells(1, 16), _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
If Not objOpen Is Nothing Then
strFirstAddressOpen = objOpen.Address
Do
Worksheets("target").Cells(lngNextRow, 1).Resize(1, 10).Value = _
.Cells(objOpen.Row, 4).Resize(1, 10).Value
strMessage = Replace$(objOpen.Text, MSG_OPEN, vbNullString)
Worksheets("target").Cells(lngNextRow, 11).Value = Trim$(strMessage)
Worksheets("target").Cells(lngNextRow, 12).Value = .Cells(objOpen.Row, 14).Value
If objDictionary.Exists(Key:=strMessage) Then
objDictionary.Item(Key:=strMessage) = objDictionary.Item(Key:=strMessage) + 1
Else
objDictionary.Item(Key:=strMessage) = 1
End If
Worksheets("target").Cells(lngNextRow, 14).Value = _
strMessage & "No. " & objDictionary.Item(Key:=strMessage)
Set objClose = .Columns(16).Find(What:=strMessage & MSG_CLOSE, After:=objOpen, _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objClose Is Nothing Then
Worksheets("target").Cells(lngNextRow, 13).Value = _
.Cells(objClose.Row, 14).Value
End If
lngNextRow = lngNextRow + 1
Set objOpen = .Columns(16).Find(What:=MSG_OPEN, After:=objOpen, _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
Loop Until objOpen.Address = strFirstAddressOpen
End If
End With
Set objDictionary = Nothing
Set objOpen = Nothing
Set objClose = Nothing
Application.ScreenUpdating = True
End Sub
Gruß
Nepumuk
Anzeige
AW: SPS Meldearchiv
06.09.2022 19:40:02
snb
Hier laüft's

Sub M_snb()
sn = Tabelle2.Cells(1).CurrentRegion
ReDim sp(UBound(sn), 15)
For j = 2 To UBound(sn)
For jj = 1 To UBound(sp)
If sp(jj, 10) = sn(j, 15) And sp(jj, 12) = "" Then
sp(jj, 12) = sn(j, 14)
Exit For
End If
If sp(jj, 10) = "" Then
sp(jj, 10) = sn(j, 15)
sp(jj, 11) = sn(j, 14)
Exit For
End If
Next
Next
Tabelle3.Cells(20, 1).Resize(UBound(sp), UBound(sp, 2)) = sp
End Sub

AW: SPS Meldearchiv
07.09.2022 14:47:57
Michael
Hallo Leute,
ich habe eben erst gesehen, dass meine gestrige Antwort gar nicht veröffentlicht wurde.
Dann versuche ich es jetzt nochmal:
Habt ganz ganz vielen Dank für eure Antworten. Ich habe die Sortierlösung von Daniel ausprobiert. Und das funktioniert tatsächlich. Man merkt, wo die Excelprofis zuhause sind. Die Makros konnte ich noch nicht probieren, weil das Thema leider etwas drängt und ich deshalb erstmal eine funktionierende Lösung haben muss.
Ich hole das aber nach.
Nochmals herzlichen Dank an euch alle.
Mi
Anzeige
AW: SPS Meldearchiv
08.09.2022 10:00:58
Daniel
Mein Makro ist die Umsetzung der Sortiermethode in VBA.
Gruß Daniel

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige