Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 10:59:29
Datei Auswählen und öffnen
19.04.2024 10:46:47
Bestimmte Zellen aus dynamischer Liste zurückgeben
19.04.2024 10:39:36
Schaltfläche auf einem Tabellenblatt NICHT mit abspeichern
19.04.2024 09:26:26
Median für Zeilen mit gleichen Zeitstempel
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1444to1448
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1444to1448
1444to1448
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

VBA Code Anpassung HELP

VBA Code Anpassung HELP
16.09.2015 14:51:27
Roffel89
Servus,
ich bekomme zwei Änderungen an meinem Code nicht allein hin und benötige dringend eure Hilfe.
Meine Arbeitsmappe:
https://www.herber.de/bbs/user/100224.xlsm
Mein aktuelles Ziel: wenn ich run makro drücke,
soll er mit in meiner Tabelle unten es wie folgt darstellen:
Userbild
Er soll die passenden Fälle, welche er aus dem zweiten Tabellenblatt zieht, unter einander so anordnen wie auf meinem Screenshot. Leider habe ich es bisher nicht hinbekommen meinen Code derart anzupassen.
Wenn das jemand drauf hat, ware ich seeeehr dankbar.
Mein Code:

Public Sub testClient()
Dim sheet As String
'sheet selector
sheet = Range("H10")
'Summary Zeile mit Datum und Anzahl der Datensätze
Dim summary As Integer
summary = checkList(sheet, 13, "Fall 4: Statusveränderung negativ")
summary = summary + checkList(sheet, 12, "Fall 3: Statusveränderung positiv")
summary = summary + checkList2(sheet, 11, "Fall 2: Keine Statusveränderung (negativ)")
summary = summary + checkList2(sheet, 10, "Fall 1: Keine Statusveränderung (positiv)")
Call newLineAndFormat
Sheets("Summary").Cells(18, 2).Value = Range("H10")
Sheets("Summary").Cells(18, 6).Value = summary
Sheets("Summary").Activate
End Sub

Function checkList(sheet As String, caseColumn As Integer, Optional label As String = "") As Integer
Dim currentRow As Long
Dim counter As Integer
'Checking List
For currentRow = Sheets(sheet).Cells.SpecialCells(xlLastCell).Column To 2 Step -1
If (Sheets(sheet).Cells(currentRow, caseColumn).Value = "True" Or _
Sheets(sheet).Cells(currentRow, caseColumn).Value = "Wahr") Then
Sheets("Summary").Cells(18, 2).Value = Range("H10")
Call newLineAndFormat
Sheets("Summary").Cells(18, 4).Value = Sheets(sheet).Cells(currentRow, 1).Value
counter = counter + 1
End If
Next currentRow
'Summary row
Call newLineAndFormat
Sheets("Summary").Cells(18, 4).Value = label
Sheets("Summary").Cells(18, 6).Value = counter
Sheets("Summary").Activate
checkList = counter
End Function
Function checkList2(sheet As String, caseColumn As Integer, Optional label As String = "") As Integer
Dim currentRow As Long
Dim counter As Integer
'Checking List
For currentRow = Sheets(sheet).Cells.SpecialCells(xlLastCell).Column To 2 Step -1
If (Sheets(sheet).Cells(currentRow, caseColumn).Value = "True" Or _
Sheets(sheet).Cells(currentRow, caseColumn).Value = "Wahr") Then
Sheets("Summary").Cells(18, 2).Value = Range("H10")
counter = counter + 1
End If
Next currentRow
'Summary row
Call newLineAndFormat
Sheets("Summary").Cells(18, 4).Value = label
Sheets("Summary").Cells(18, 6).Value = counter
Sheets("Summary").Activate
checkList2 = counter
End Function 


Private Sub newLineAndFormat()

Sheets("Summary").Activate

Sheets("Summary").Rows("18:18").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

Sheets("Summary").Range("19:19").Copy

Sheets("Summary").Rows("18:18").PasteSpecial Paste:=xlPasteFormats

Sheets("Summary").Range("B18").Select

Application.CutCopyMode = False

End Sub


Momentan sieht es leider noch so aus:
Userbild
Hier verstehe ich auch nicht wieso, er mir bei zwei Zeilen das Datum nicht vorne mitgibt... weiß hierzu jemand Rat?
Beste Grüße
Roffel

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Code Anpassung HELP
16.09.2015 16:08:41
Rudi
Hallo,
lieber komplett neu als deinen Code zu analysieren.
Sub aaaa()
Dim objDaten As Object, oD, arrOut
Dim i As Long, j As Integer, sKey As String, iFall As Integer
Set objDaten = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
With Sheets(CStr(Sheets("Summary").Range("H10")))
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
For j = 10 To 13
If .Cells(i, j) = True Then
iFall = j - 9
Exit For
End If
Next j
sKey = .Name & "|" & iFall & "|" & .Cells(i, 1)
objDaten(sKey) = objDaten(sKey) + 1
Next i
End With
ReDim arrOut(1 To objDaten.Count, 1 To 5)
i = 0
For Each oD In objDaten
i = i + 1
arrOut(i, 1) = Split(oD, "|")(0)
arrOut(i, 3) = "Fall" & Split(oD, "|")(1)
arrOut(i, 4) = Split(oD, "|")(2)
arrOut(i, 5) = objDaten(oD)
Next
With Sheets("Summary")
.Rows("19:1000").Delete
.Cells(18, 2).Resize(UBound(arrOut), UBound(arrOut, 2)) = arrOut
.Cells(18, 2).Resize(, 15).Copy
.Cells(18, 2).Resize(UBound(arrOut), 15).PasteSpecial xlPasteFormats
.Cells(17, 2).Sort key1:=.Cells(18, 4), order1:=xlAscending, Header:=xlYes
.Cells(18, 2).Resize(UBound(arrOut), 2).Merge True
.Cells(18, 2).Select
End With
Application.CutCopyMode = False
End Sub
Gruß
Rudi
Anzeige

Links zu Excel-Dialogen

Label

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige