Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
912to916
912to916
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Rows in Array einlesen (Dup.check) und Transpose

Rows in Array einlesen (Dup.check) und Transpose
07.10.2007 08:51:00
Robert
Guten Morgen Leute,
Ich habe mein VBA Anliegen Gestern schon auf dem Forum gepostet aber leider ist aus irgendeinem Grund ein Durcheinander entstanden. Mehrere Forumler haben in meinem Posting geschrieben.
Hallo Franz und Sepp. Danke schon mal dass ihr dran arbeitet. Franz, dein Lösung Vorschlag lauft aber nicht so wo ich es mir erhofft habe.
Du hast mir diese Woche schon mal geholfen mit dem VBA Thema „Tabelle Aufgrund von/bis Datum (Periodebereich)“ Ich habe dein Code so umprogrammiert dass es für meine Zwecke
Passt. Der Identifier kommt (in der erste spalte) öfters vor und dass muss auch so sein. Doch was nicht sein darf ist dass nach dem Transpose Identifier mit den gleichen Identifiernamen in den Spalten stehen.
In dem Code (Tabelle Aufgrund von/bis Datum (Periodebereich) wird der Identifier und Datum kontrolliert. Nachhinein habe ich aber gemerkt dass zusätzliche Kriterien geprüft werden müssen. Darum das Posting „Rows in Array einlesen (Dup.check) und Transpose„
Bedingungen sind Identifier und Datum (Start und End) und nachhinein auch noch der Identifiername und Typ. Ich schätze dass ist nur zu erreichen wenn Zeilen mit ausgewählten Identifier und zutreffendes Datum samt Identifiername und Typ via eine Schleife ins Array kommen. Wenn dann der Identifiername und Typ schon vorkommen, müsste der Eintrag nicht noch mal stattfinden.
Ein Teil vom Code hänge ich mal an. Ich schätze dass der Code ab der Datumscheck durch eine Arraylösung ersetzt werden muss? Da könnt ihr doch bestimmt helfen.. Gruss, Robert
wksDaten.Select
iSpalte = 3
For lZeile = 2 To wksDaten.Cells(.Rows.Count, 20).End(xlUp).Row
If wksDaten.Cells(lZeile, 20).Value = BMID_auswahl Then
If DatumsCheck(Start:=wksDaten.Cells(lZeile, 30), _
Ende:=IIf(IsEmpty(wksDaten.Cells(lZeile, 31)), tEnde, _
wksDaten.Cells(lZeile, 31)), _
PeriodeStart:=tStart, PeriodeEnde:=tEnde) = True Then
wksDaten.Range(Cells(lZeile, 20), Cells(lZeile, 32)).Copy
lZ_Start = 1
wks.Cells(lZ_Start, iSpalte).PasteSpecial Paste:=xlPasteAll, Transpose:=True
End If
iSpalte = iSpalte + 1
End If
Next

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Rows in Array einlesen (Dup.check) und Transpo
07.10.2007 15:44:00
fcs
Hallo Roland,
dass manchmal eine Frage bei den Antworten etwas vom Thema wegläuft passiert schon mal ist aber doch kein Grund einen neu Thread aufzumachen. es hätte gereicht die Frage mit der Zwischenfrage wieder auf offen zu setzen.
Warum stelltst du deine Frage eigentlich nicht mit einer kleinen Beispieldatei und halbwegs komplettem Code.
Da ich meistens versuche meine Lösungsvorschläge auch zu testen ist es unnötig zeitaufwendig die Testdaten immer erst selber zusammenbasteln zu müssen. Außerdem werden so Mißverständnisse leichter vermieden.
Hier mein Lösungsvorschlag. Allerdings frage ich mich wieso du bei Einstfung VBA und Excel gut so eine relativ einfache Schleifenkonstruktion nicht selber auf die Reihe bekommen hast.
Gruß
Franz

Sub aatest()
Dim wksDaten As Worksheet, wks As Worksheet, BMID_auswahl
Dim iSpalte%, lZ_Start&, lZeile&
Dim tEnde As Date, tStart As Date
Dim arrTemp(), boNeu As Boolean, arrSpalte%, arrZeile%
Set wks = Worksheets("Tabelle2")
Set wksDaten = Worksheets("Tabelle1")
'Vorgabewerte einlesen
tStart = wks.Range("A1")
tEnde = wks.Range("A2")
BMID_auswahl = wks.Range("A3")
With wks
'#### bis hier Zeilen zum Testen
wksDaten.Select
iSpalte = 3
lZ_Start = 1
ReDim arrTemp(20 To 32, 0)
For lZeile = 2 To wksDaten.Cells(.Rows.Count, 20).End(xlUp).Row
If wksDaten.Cells(lZeile, 20).Value = BMID_auswahl Then
If DatumsCheck(Start:=wksDaten.Cells(lZeile, 30), _
Ende:=IIf(IsEmpty(wksDaten.Cells(lZeile, 31)), tEnde, _
wksDaten.Cells(lZeile, 31)), _
PeriodeStart:=tStart, PeriodeEnde:=tEnde) = True Then
'Dopplungen prüfen
boNeu = True
'prüfen von Identifiername in Spalte 21 und Typ in Spate 24
If UBound(arrTemp, 2) > 0 Then
For arrSpalte = LBound(arrTemp, 2) To UBound(arrTemp, 2)
If arrTemp(21, arrSpalte) = wksDaten.Cells(lZeile, 21) And _
arrTemp(24, arrSpalte) = wksDaten.Cells(lZeile, 24) Then
boNeu = False
Exit For
End If
Next
End If
If boNeu = True Then
If UBound(arrTemp, 2) = 0 Then
ReDim arrTemp(20 To 32, 1 To UBound(arrTemp, 2) + 1)
Else
ReDim Preserve arrTemp(20 To 32, 1 To UBound(arrTemp, 2) + 1)
End If
For arrZeile = 20 To 32
arrTemp(arrZeile, UBound(arrTemp, 2)) = wksDaten.Cells(lZeile, arrZeile)
Next
wksDaten.Range(Cells(lZeile, 20), Cells(lZeile, 32)).Copy
wks.Cells(lZ_Start, iSpalte).PasteSpecial Paste:=xlPasteAll, Transpose:=True
iSpalte = iSpalte + 1
End If
End If
End If
Next
'#### ab hier Zeilen zum testen
End With
ReDim arrTemp(0, 0): Set wks = Nothing: Set wksDaten = Nothing
End Sub


Anzeige
AW: Rows in Array einlesen (Dup.check) und Transpose
07.10.2007 23:02:00
Josef
Hallo Robert,
hiereine Lösung ohne Array's und Schleifen, dafür mit dem Spezialfilter.
Das Beispeil geht von Daten im Bereich "A2:Jxx" aus. Die erste Zeile enthält Überschriften.
Die Spalten mit den möglichen Duplikaten sind "C" und "F". Die Transponierte Liste wird in einem neuen Tabellenblatt eingefügt.
Sub FilterTranspose()
Dim rng As Range
Dim objWSA As Worksheet, objWSB As Worksheet

On Error GoTo ErrExit

With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

Set rng = ActiveSheet.Range("A1").CurrentRegion

If rng.Rows.Count > Columns.Count Then
    MsgBox "Aktion nicht möglich!", vbInformation, "Hinweis"
Else
    Set objWSB = ThisWorkbook.Worksheets.Add(after:=ActiveSheet)
    Set objWSA = ThisWorkbook.Worksheets.Add(after:=ActiveSheet)
    
    objWSA.Name = "Filter_" & Format(Now, "ddmmyy_hhmmss")
    
    rng.Copy objWSA.Range("A1")
    
    objWSA.Range("N2").Formula = "=SUMPRODUCT(($C$2:$C$285=C2)*($F$2:$F$285=F2))=1"
    
    objWSA.Range("A1").CurrentRegion.AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=objWSA.Range("L1:N2"), _
        CopyToRange:=objWSB.Range("A1"), _
        Unique:=True
    
    objWSA.Cells.ClearContents
    
    objWSB.Range("A1").CurrentRegion.Copy
    
    objWSA.Range("A1").PasteSpecial _
        Paste:=xlPasteAll, _
        Operation:=xlNone, _
        SkipBlanks:=False, _
        Transpose:=True
    
    Application.CutCopyMode = False
    
    objWSB.Delete
End If

ErrExit:

Set objWSA = Nothing
Set objWSB = Nothing
Set rng = Nothing

With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub

Gruß Sepp

Anzeige

210 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige