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
1508to1512
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
1508to1512
1508to1512
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

VBA - Matrixl mit mehreren Ergebnissen optimieren

VBA - Matrixl mit mehreren Ergebnissen optimieren
29.08.2016 22:02:06
Kasimir
Hallo zusammen,
ich habe eine Excelfile mit zwei Tabellenbittern. Im ersten Tabellenblatt sind Veranstaltungen aufgelistet mit Anfangsdatum und Enddatum.
Auf dem zweiten ist ein Jahreskalender. Hier sollen pro Tag überprüft werden, ob eine Veranstaltung ansteht für diesen Tag.
Meine jetzige erfüllt zwar seinen Zweck. Aber er ist sehr sehr schlecht und langsam. Meine VBA Kenntnisse haben nicht für mehr angepasst. Kann den Code optimieren, damit er schneller wird? Pro Tag sind es aktuell max. 4 Veranstaltungen.
Eine Beispielsdatei folgt gleich.
Hier ein Auszug aus der Formel - exemplarisch für die ersten Januartage
Sub Januar()
Cells(3, 2).FormulaArray = _
"=IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-1],ROW(R1:R999)),ROW(Veranstaltungen!R1C2))),"""")
&CHAR(10)&IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-1],ROW(R1:R999)),ROW(Veranstaltungen!R2C2))),"""")"
Cells(3, 2).Copy
Cells(3, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Cells(3, 3).FormulaArray = _
"=IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-2],ROW(R1:R999)),ROW(Veranstaltungen!R3C2))),"""")
&CHAR(10)&IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-2],ROW(R1:R999)),ROW(Veranstaltungen!R4C2))),"""")"
Cells(3, 3).Copy
Cells(3, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Cells(4, 2).FormulaArray = _
"=IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-1],ROW(R1:R999)),ROW(Veranstaltungen!R1C2))),"""")
&CHAR(10)&IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-1],ROW(R1:R999)),ROW(Veranstaltungen!R2C2))),"""")"
Cells(4, 2).Copy
Cells(4, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Cells(4, 3).FormulaArray = _
"=IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-2],ROW(R1:R999)),ROW(Veranstaltungen!R3C2))),"""")
&CHAR(10)&IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-2],ROW(R1:R999)),ROW(Veranstaltungen!R4C2))),"""")"
Cells(4, 3).Copy
Cells(4, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Cells(5, 2).FormulaArray = _
"=IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-1],ROW(R1:R999)),ROW(Veranstaltungen!R1C2))),"""")
&CHAR(10)&IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-1],ROW(R1:R999)),ROW(Veranstaltungen!R2C2))),"""")"
Cells(5, 2).Copy
Cells(5, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Cells(5, 3).FormulaArray = _
"=IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-2],ROW(R1:R999)),ROW(Veranstaltungen!R3C2))),"""")
&CHAR(10)&IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-2],ROW(R1:R999)),ROW(Veranstaltungen!R4C2))),"""")"
Cells(5, 3).Copy
Cells(5, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Cells(6, 2).FormulaArray = _
"=IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-1],ROW(R1:R999)),ROW(Veranstaltungen!R1C2))),"""")
&CHAR(10)&IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-1],ROW(R1:R999)),ROW(Veranstaltungen!R2C2))),"""")"
Cells(6, 2).Copy
Cells(6, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Cells(6, 3).FormulaArray = _
"=IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-2],ROW(R1:R999)),ROW(Veranstaltungen!R3C2))),"""")
&CHAR(10)&IFERROR(INDEX(Veranstaltung,SMALL(IF(Anfangsdatum=RC[-2],ROW(R1:R999)),ROW(Veranstaltungen!R4C2))),"""")"
Cells(6, 3).Copy
Cells(6, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Gruß
Kasimir

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA - Matrixl mit mehreren Ergebnissen optimieren
30.08.2016 11:55:28
baschti007
Hey Kasimir
Ich habe hier ein kleines Bsp.

Sub Create()
Application.DisplayAlerts = False
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim x As Date
Dim i As Long
Dim c As Range
i = 2
ThisWorkbook.Worksheets("Overview").Delete
Set Ws1 = ThisWorkbook.Worksheets("Veranstaltungen")
Set Ws2 = Worksheets.Add
Ws2.Name = "Overview"
Call Jahreskalender_anlegen
Do
If Ws1.Cells(i, 2).Value = "" Then Exit Do
For x = Ws1.Cells(i, 2) To Ws1.Cells(i, 3)
Set c = Ws2.UsedRange.Find(Format(x, "DDD DD.MM.YYY"), LookIn:=xlFormulas, LookAt:=xlWhole)
If c Is Nothing Then Exit Sub
If c.Offset(0, 1) = "" Then
c.Offset(0, 1) = Ws1.Cells(i, 6)
Else
c.Offset(0, 1) = c.Offset(0, 1) & " , " & Ws1.Cells(i, 6)
End If
c.Offset(0, 1).Interior.ColorIndex = 45
Next
i = i + 1
Loop
Ws2.UsedRange.Cells.EntireColumn.AutoFit
End Sub
Sub Jahreskalender_anlegen()
'legt für das aktuelle Jahr einen Kalender an
Dim Jahr As String
Dim Monat As Integer, Tag As Integer, AnzTage As Integer
Dim d As Date
On Error GoTo Fehler
Jahr = Year(Date)
For Monat = 1 To 24 ' Hier anzahl der Monate anpassen wenn 12 dann dieses Jahr wenn 24 dann  _
Dieses Jahr und 2017
'Anzahl Tage des Monats
AnzTage = DateSerial(Year(Now), Monat + 1, 1) _
- DateSerial(Year(Now), Monat, 1)
Cells(1, Monat + i) = Format(DateSerial(Year(Now), Monat, 1), "MMM YYYY")
Cells(1, Monat + i + 1) = "Veranstaltungen"
For Tag = 1 To AnzTage
With Cells(1 + Tag, Monat + i)
d = DateSerial(Jahr, Monat, Tag)
.Value = Format(d, "DDD DD.MM.YYY")
If (Format(d, "DDD") = "Sa" Or Format(d, "DDD") = "So") Then .Interior.ColorIndex =  _
15
End With
Next Tag
Tag = 1
i = i + 1
Next Monat
Exit Sub
Fehler:
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub
Gruß Basti
Anzeige
AW: VBA - Matrixl mit mehreren Ergebnissen optimieren
30.08.2016 12:59:32
kasimir
Hi Basti,
vielen vielen Dank für den Code.
Er auf jedenfall schöner und schneller. Aber irgendwas mache ich noch falsch.
Hier mal ein Auszug vom Ergebnis. Unter Veranstaltung wird nicht aufgeführt :(
Jan 16 Veranstaltungen
Fr 01.01.2016
Sa 02.01.2016
So 03.01.2016
Mo 04.01.2016
Di 05.01.2016
Ich muss mir mal heute abend deinen Code in Ruhe anschauen.
Gruß
kasimir
AW: VBA - Matrixl mit mehreren Ergebnissen optimieren
30.08.2016 13:05:23
baschti007
Hey du musst den Code "Create" Starten nicht "Jahreskalender_anlegen"
Gruß Basti

Sub Create()
Application.DisplayAlerts = False
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim x As Date
Dim i As Long
Dim c As Range
i = 2
ThisWorkbook.Worksheets("Overview").Delete
Set Ws1 = ThisWorkbook.Worksheets("Veranstaltungen")
Set Ws2 = Worksheets.Add
Ws2.Name = "Overview"
Call Jahreskalender_anlegen
Do
If Ws1.Cells(i, 2).Value = "" Then Exit Do
For x = Ws1.Cells(i, 2) To Ws1.Cells(i, 3)
Set c = Ws2.UsedRange.Find(Format(x, "DDD DD.MM.YYYY"), LookIn:=xlFormulas, LookAt:=xlWhole)
If c Is Nothing Then Exit Sub
If c.Offset(0, 1) = "" Then
c.Offset(0, 1) = Ws1.Cells(i, 6)
Else
c.Offset(0, 1) = c.Offset(0, 1) & " , " & Ws1.Cells(i, 6)
End If
c.Offset(0, 1).Interior.ColorIndex = 45
Next
i = i + 1
Loop
Ws2.UsedRange.Cells.EntireColumn.AutoFit
Call rahmen
End Sub
Sub Jahreskalender_anlegen()
'legt für das aktuelle Jahr einen Kalender an
Dim Jahr As String
Dim Monat As Integer, Tag As Integer, AnzTage As Integer
Dim d As Date
On Error GoTo Fehler
Jahr = Year(Date)
For Monat = 1 To 24 ' Hier anzahl der Monate anpassen wenn 12 dann dieses Jahr wenn 24 dann  _
Dieses Jahr und 2017
'Anzahl Tage des Monats
AnzTage = DateSerial(Year(Now), Monat + 1, 1) _
- DateSerial(Year(Now), Monat, 1)
With ActiveSheet.Cells(1, Monat + i)
.Value = Format(DateSerial(Year(Now), Monat, 1), "MMM YYYY")
.Offset(0, 1) = "Veranstaltungen"
.Font.Bold = True
.Offset(0, 1).Font.Bold = True
.Font.Size = 12
.Offset(0, 1).Font.Size = 12
End With
For Tag = 1 To AnzTage
With Cells(1 + Tag, Monat + i)
d = DateSerial(Jahr, Monat, Tag)
.Value = Format(d, "DDD DD.MM.YYYY")
If (Format(d, "DDD") = "Sa" Or Format(d, "DDD") = "So") Then .Interior.ColorIndex =  _
15
End With
Next Tag
Tag = 1
i = i + 1
Next Monat
Exit Sub
Fehler:
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub

Anzeige
AW: VBA - Matrixl mit mehreren Ergebnissen optimieren
30.08.2016 14:04:06
kasimir
Hi,
ja das mache ich auch. Allerding ist im "Create" der Befehl "Call Jahreskalender_anlegen"
Ein Frage noch. Du hast hier jetzt ein Call rahmen eingebaut. Für was ist der
Loop
Ws2.UsedRange.Cells.EntireColumn.AutoFit
Call rahmen
End Sub
AW: VBA - Matrixl mit mehreren Ergebnissen optimieren
30.08.2016 14:30:10
baschti007
Ja Sorry den Rahmen hatte ich bei mir aber einfach rauslöschen dann läuft das Makro.
Gruß Basti
AW: VBA - Matrixl mit mehreren Ergebnissen optimieren
30.08.2016 14:59:16
kasimir
hi,
danke. Ich teste es heute abend nochmal in ruhe.
Gruß
kasimir
AW: VBA - Matrixl mit mehreren Ergebnissen optimieren
30.08.2016 15:37:28
kasimir
top geht :)
AW: VBA - Matrixl mit mehreren Ergebnissen optimieren
30.08.2016 15:42:50
baschti007
Super =D
Schönen Tag noch
AW: VBA - Matrixl mit mehreren Ergebnissen optimieren
31.08.2016 22:42:48
kasimir
Hallo zusammen,
eine kleine Frage hätte ich noch. Beim Jahreskalender werden bei mir die Tagen als Format "Text" angelegt. Wie müsste ich den Code umschreiben, damit die Wert als Datumsformat sind?
VG
kasimir
Anzeige
AW: VBA - Matrixl mit mehreren Ergebnissen optimieren
01.09.2016 10:19:39
kasimir
Hi,
anbei die Beispieldatei mit dem leicht modifizierten Code.
Ich würde gerne Bedingteformatierungen verwenden. Allerding werden die Werte im Kalender als "Text" eingetragen, weshalb die Bedingte Formatierung nicht funktioniert.
https://www.herber.de/bbs/user/107935.xlsm
Gruß
kasimir
AW: VBA - Matrixl mit mehreren Ergebnissen optimieren
01.09.2016 12:38:39
baschti007
Hey Mach das doch einfach gleich beim Kalender anlegen .

Sub Jahreskalender_anlegen()
'legt für das aktuelle Jahr einen Kalender an
Dim Jahr As String
Dim Monat As Integer, Tag As Integer, AnzTage As Integer
Dim d As Date
Dim c As Range
Dim dict As Object
Set dict = CreateObject("scripting.Dictionary")
With dict
.CompareMode = BinaryCompare
On Error GoTo Fehler
For Each c In Range("Feiertag")
If Not .Exists(c.Value) Then
.Add c.Value, 1
End If
Next
End With
Jahr = Year(Date)
i = 1
For Monat = 1 To 24 ' Hier anzahl der Monate anpassen wenn 12 dann dieses Jahr wenn 24  _
dann _
Dieses Jahr und 2017
'Anzahl Tage des Monats
AnzTage = DateSerial(Year(Now), Monat + 1, 1) _
- DateSerial(Year(Now), Monat, 1)
Cells(2, Monat + i) = Format(DateSerial(Year(Now), Monat, 1), "MMM YYYY")
Cells(2, Monat + i + 1) = " "
For Tag = 1 To AnzTage
With Cells(2 + Tag, Monat + i)
d = DateSerial(Jahr, Monat, Tag)
.Value = Format(d, "DDD DD.MM.YYYY")
If (Format(d, "DDD") = "Sa" Or Format(d, "DDD") = "So") Then .Interior.ColorIndex =  _
15
If dict.Exists(d) Then .Interior.ColorIndex = 3 ' Hier Farbe für Feiertage
End With
Next Tag
Tag = 1
i = i + 1
Next Monat
Exit Sub
Fehler:
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub
Gruß Basti
Anzeige

307 Forumthreads zu ähnlichen Themen

Ausgabe von mehreren Werten anhand Suchkriterium
mehreren

Hallo Zusammen,
mich interessiert, ob es zu dem nachfolgenden Problem eine relativ simple Excel Lösung gibt.
Ich habe eben mal das Forum durchsucht, allerdings nichts passendes gefunden. Ich nehmen aber mal an, dass ich einfach nicht die richtigen Suchbegriffe weiß. Sprich: wer einen Li...
20.08.2008 13:46:17
Thread-ID: 1003193
4 Beiträge
Anzeige
SVERWEIS mit mehreren Einträgen
Tom

Hallo,
Ich führe ein Transaktionsjournal, welches ich auswerten möchte. Folgende Spalten habe ich zur Verfügung:
Datum
Text
Betrag
Pro Datum kann es mehrere Einträge geben.
Ich möchte nun eine konsolidierte Tabelle erstellen, in welcher pro Datum alle Texte und der Gesa...
19.01.2009 17:01:00
Thread-ID: 1041567
3 Beiträge
Suche mit mehreren Kriterien
Peter

Hi Excelfreaks,
ich habe hier eine umfangreiche Datei, in der Datensätze gesucht werden sollen, die mehrere Kriterien (mindestens zwei, maximal drei Kriterien) erfüllen.
Für ein Kriterium benutze ich den Autofilter, aber danach weitere zweimal mit Autofilter, das nervt.
Ich suche ei...
29.01.2009 14:59:18
Thread-ID: 1045036
3 Beiträge
Anzeige
Funktion SUCHEN o.ä. mit mehreren Suchbegriffen
Nico

Morjen,
sacht mal, was ist an der Syntax falsch? Ich will eine Zelle nach mehreren Begriffen durchsuchen und wenn einer dieser Begriffe enthalten ist, soll der Inhalt der Zelle ausgegeben werden.
Folgende Syntax verwende ich bisher für den Teil der Funktion SUCHEN:
=Wenn(Oder(Suchen...
19.05.2009 09:17:25
Thread-ID: 1076059
8 Beiträge
(Sverweis?!) Mehrere Werte wiedergeben?
Reinhardt

Hallo liebe Excelgemeinde,
ich habe wieder mal ein Problem:
Undzwar habe ich eine Tabelle, wo Ländernamen den entsprechenden Mitarbeitern zugeordnet sind.
Ein Mitarbeiter kann für mehrere Länder verantwortlich sein
Nun habe ich in einer zweiten Tabelle eine Dropdown box mit de...
08.07.2009 19:06:35
Thread-ID: 1087254
5 Beiträge
Sverweis und suche suche über mehrere Spalten
Sabine

Hi
Folgendes Problem. In Tabelle1 Spalte A stehen werte, die in Tabelle 2 in Spalte B-F gesucht werden sollen und dann der wert aus Spalte X ausgegeben werden.
Mit Sverweis geht das nicht, aber wie dann?
30.07.2009 18:44:34
Thread-ID: 1092620
2 Beiträge
Suchen mit mehreren Kriterien
Gorkij

Guten Morgen, liebe Leute,
habe folgendes Problem:
Ich möchte erreichen, dass in der Spalte B ein Wert (1) eingefügt wird, wenn die Zeile auf gleicher Höhe in Spalte A eines von ca.15 Kriterien enthält. Problem dabei ist, dass diese Spalte A nicht nur das Kriterium enthält, sondern auch...
14.08.2009 10:33:33
Thread-ID: 1095886
15 Beiträge
Suche mit mehreren Filenamen
Lang

Hallo Excelfreunde,
mit der nachfolgenden Prozedur finde ich in "C:\" alle Dateien mit dem (Beispiel-)Namen "abcdefgh".
Wie muss die Prozedur ergänzt werden, damit sie gleichzeitig auch Namensteile wie "ab", "cd", "ef" usw. in die Suche einbindet und diese in der Tabelle "Fundus" ausgeg...
28.08.2009 20:53:47
Thread-ID: 1099202
3 Beiträge
Anzeige

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige
Archiv - Verwandte Themen
Forumthread
Beiträge
3
9
2
2
2
7
4
1
14
2
1
4
3
4
9
6
8
2
1
4
11
2
15
9
7