Supportnet / Forum / Tabellenkalkulation

Guten Morgen ihr Excel bzw. VBA Spezies da draußen. Ich habe folgendes Makro: Sub Abteilungen_Zeitbalken_färben() Dim iRow As Long, iCol As Integer, Anfang As Integer, Ende As Integer, Farbe As Integer, _ Kommentar As String For iRow = 8 To 555 For iCol = 7 To 190 If Cells(iRow, 2) = "Konstruktion" And Cells(iRow, 3) = Cells(4, iCol) Then Anfang = iCol GoTo w1 End If Next w1: For iCol = 7 To 190 If Cells(iRow, 2) = "Konstruktion" Then a = iRow GoTo w2 End If Next w2: For iCol = 7 To 190 If Cells(iRow, 2) = "Konstruktion" And Cells(iRow, 4) = Cells(4, iCol) Then Kommentar = Cells(iRow, 4).Comment.Text Ende = iCol GoTo e1 End If Next e1: Range(Cells(a, Anfang), Cells(a, Ende)).Interior.ColorIndex = 24 With Cells(a, Ende) On Error Resume Next .Comment.Delete .AddComment .Comment.Text Text:=Kommentar End With Next For iRow = 8 To 555 For iCol = 7 To 190 If Cells(iRow, 2) = "Elektrik" And Cells(iRow, 3) = Cells(4, iCol) Then Anfang = iCol GoTo w3 End If Next w3: For iCol = 7 To 190 If Cells(iRow, 2) = "Elektrik" Then b = iRow GoTo w4 End If Next w4: For iCol = 7 To 190 If Cells(iRow, 2) = "Elektrik" And Cells(iRow, 4) = Cells(4, iCol) Then Kommentar = Cells(iRow, 4).Comment.Text Ende = iCol GoTo e2 End If Next e2: Range(Cells(b, Anfang), Cells(b, Ende)).Interior.ColorIndex = 37 With Cells(b, Ende) On Error Resume Next .Comment.Delete .AddComment .Comment.Text Text:=Kommentar End With Next Das ist nur ein Auszug. Es werden noch weitere Abteilungen abgefragt. Das Makro wird mit einem Klick eines Buttons aktiviert und aktualisiert die Daten. Allerdings dauert das viel zu lang. Gibt es eine Möglichkeit, die Abfrage zu vereinfachen? Vielen Dank im Voraus MfG Zoe

Hallo,

zumindest wären aus meiner Sicht eine Reduzierung die For -Schleifen wahrscheinlich möglich, jedoch wäre dafür ein Beispiel mit dem gesamten Makro nicht schlecht. Es sind in dem Beispiel viele Wiederholungen die zusammenfassbar sind oder durch einen anderen Aufbau vielleicht effektiver zu gestalten sind. So könnte ich mir vorstellen in einem Arrayfeld die Daten wie "Konstruktion, Elektrik, ...." und als 2. Angabe " 24,37,...." einzurichten und alles über eine entsprechende Schleife abzudecken.

Dein Beispiel könnest du bei

http://www.netupload.de/

einstellen und den Link hier hinterlegen

Gruß

Helmut

Hallo Saarbauer.

Ich wollte es versuchen, aber meine Datei ist 6,5MB groß und bei netupload darf sie nur max. 3MB groß sein.´

Ich erklär dir kurz meine Tabelle:
In Spalte A stehen Projekte. In Spalte B werden die dazu gehörigen Arbeitsschritte festgehalten z.B. Konstruktion, Elektrik, ... In Spalte C gibt es einen Starttermin für jeden Abschnitt. In Spalte D steht der Endtermin mit entsprechendem Kommentar.
In der Zeile 4 von Spalte G bis GH sind Datumsangaben gemacht. Mit diesen Daten (MZ von Datum) werden die Termine aus Spalte C und D verglichen. Demnach werden Zellen gefärbt.

Die Tabelle stellt eine Projektübersicht dar. Optisch soll sie MS Project ähneln, wenn dir das was sagt.

MfG Zoe

Hallo Saarbauer, hier der 2. Teil meiner Antwort, da nur 5000 Zeichen erlaubt
Hier hast du das komplette Makro (ich hoffe es haut dich nicht um, bin noch Anfänger und daher froh, dass es erstmal auf diese Weise funktioniert hat.

Sub Abteilungen_Zeitbalken_färben()
Dim iRow As Long, iCol As Integer, Anfang As Integer, Ende As Integer, Farbe As Integer, _
Kommentar As String
For iRow = 8 To 555
For iCol = 7 To 190
If Cells(iRow, 2) = "Konstruktion" And Cells(iRow, 3) = Cells(4, iCol) Then
Anfang = iCol
GoTo w1
End If
Next
w1:
For iCol = 7 To 190
If Cells(iRow, 2) = "Konstruktion" Then
a = iRow
GoTo w2
End If
Next
w2:
For iCol = 7 To 190
If Cells(iRow, 2) = "Konstruktion" And Cells(iRow, 4) = Cells(4, iCol) Then
Kommentar = Cells(iRow, 4).Comment.Text
Ende = iCol
GoTo e1
End If
Next
e1:
Range(Cells(a, Anfang), Cells(a, Ende)).Interior.ColorIndex = 24
With Cells(a, Ende)
On Error Resume Next
.Comment.Delete
.AddComment
.Comment.Text Text:=Kommentar
End With
Next
For iRow = 8 To 555
For iCol = 7 To 190
If Cells(iRow, 2) = "Elektrik" And Cells(iRow, 3) = Cells(4, iCol) Then
Anfang = iCol
GoTo w3
End If
Next
w3:
For iCol = 7 To 190
If Cells(iRow, 2) = "Elektrik" Then
b = iRow
GoTo w4
End If
Next
w4:
For iCol = 7 To 190
If Cells(iRow, 2) = "Elektrik" And Cells(iRow, 4) = Cells(4, iCol) Then
Kommentar = Cells(iRow, 4).Comment.Text
Ende = iCol
GoTo e2
End If
Next
e2:
Range(Cells(b, Anfang), Cells(b, Ende)).Interior.ColorIndex = 37
With Cells(b, Ende)
On Error Resume Next
.Comment.Delete
.AddComment
.Comment.Text Text:=Kommentar
End With
Next
For iRow = 8 To 555
For iCol = 7 To 190
If Cells(iRow, 2) = "Einkauf" And Cells(iRow, 3) = Cells(4, iCol) Then
Anfang = iCol
GoTo w5
End If
Next
w5:
For iCol = 7 To 190
If Cells(iRow, 2) = "Einkauf" Then
c = iRow
GoTo w6
End If
Next
w6:
For iCol = 7 To 190
If Cells(iRow, 2) = "Einkauf" And Cells(iRow, 4) = Cells(4, iCol) Then
Kommentar = Cells(iRow, 4).Comment.Text
Ende = iCol
GoTo e3
End If
Next
e3:
Range(Cells(c, Anfang), Cells(c, Ende)).Interior.ColorIndex = 34
With Cells(c, Ende)
On Error Resume Next
.Comment.Delete
.AddComment
.Comment.Text Text:=Kommentar
End With
Next

For iRow = 8 To 555
For iCol = 7 To 190
If Cells(iRow, 2) = "Mechanik" And Cells(iRow, 3) = Cells(4, iCol) Then
Anfang = iCol
GoTo w7
End If
Next
w7:
For iCol = 7 To 190
If Cells(iRow, 2) = "Mechanik" Then
d = iRow
GoTo w8
End If
Next
w8:
For iCol = 7 To 190
If Cells(iRow, 2) = "Mechanik" And Cells(iRow, 4) = Cells(4, iCol) Then
Kommentar = Cells(iRow, 4).Comment.Text
Ende = iCol
GoTo e4
End If
Next
e4:
Range(Cells(d, Anfang), Cells(d, Ende)).Interior.ColorIndex = 35
With Cells(d, Ende)
On Error Resume Next
.Comment.Delete
.AddComment
.Comment.Text Text:=Kommentar
End With
Next

Ich hoffe du kannst noch was damit anfangen.
Danke schonmal für die Geduld beim durchlesen.

MfG Zoe

Teil 3 - Der Rest:

For iRow = 8 To 555
For iCol = 7 To 190
If Cells(iRow, 2) = "Abnahme intern" And Cells(iRow, 3) = Cells(4, iCol) Then
Anfang = iCol
GoTo w9
End If
Next
w9:
For iCol = 7 To 190
If Cells(iRow, 2) = "Abnahme intern" Then
e = iRow
GoTo w10
End If
Next
w10:
For iCol = 7 To 190
If Cells(iRow, 2) = "Abnahme intern" And Cells(iRow, 4) = Cells(4, iCol) Then
Kommentar = Cells(iRow, 4).Comment.Text
Ende = iCol
GoTo e5
End If
Next
e5:
Range(Cells(e, Anfang), Cells(e, Ende)).Interior.ColorIndex = 46
With Cells(e, Ende)
On Error Resume Next
.Comment.Delete
.AddComment
.Comment.Text Text:=Kommentar
End With
Next

For iRow = 8 To 555
For iCol = 7 To 190
If Cells(iRow, 2) = "Versand" And Cells(iRow, 3) = Cells(4, iCol) Then
Anfang = iCol
GoTo w11
End If
Next
w11:
For iCol = 7 To 190
If Cells(iRow, 2) = "Versand" Then
f = iRow
GoTo w12
End If
Next
w12:
For iCol = 7 To 190
If Cells(iRow, 2) = "Versand" And Cells(iRow, 4) = Cells(4, iCol) Then
Kommentar = Cells(iRow, 4).Comment.Text
Ende = iCol
GoTo e6
End If
Next
e6:
Range(Cells(f, Anfang), Cells(f, Ende)).Interior.ColorIndex = 19
With Cells(f, Ende)
On Error Resume Next
.Comment.Delete
.AddComment
.Comment.Text Text:=Kommentar
End With
Next

For iRow = 8 To 555
For iCol = 7 To 190
If Cells(iRow, 2) = "Montage beim Kunden" And Cells(iRow, 3) = Cells(4, iCol) Then
Anfang = iCol
GoTo w13
End If
Next
w13:
For iCol = 7 To 190
If Cells(iRow, 2) = "Montage beim Kunden" Then
g = iRow
GoTo w14
End If
Next
w14:
For iCol = 7 To 190
If Cells(iRow, 2) = "Montage beim Kunden" And Cells(iRow, 4) = Cells(4, iCol) Then
Kommentar = Cells(iRow, 4).Comment.Text
Ende = iCol
GoTo e7
End If
Next
e7:
Range(Cells(g, Anfang), Cells(g, Ende)).Interior.ColorIndex = 40
With Cells(g, Ende)
On Error Resume Next
.Comment.Delete
.AddComment
.Comment.Text Text:=Kommentar
End With
Next

For iRow = 8 To 555
For iCol = 7 To 190
If Cells(iRow, 2) = "Abnahme extern" And Cells(iRow, 3) = Cells(4, iCol) Then
Anfang = iCol
GoTo w15
End If
Next
w15:
For iCol = 7 To 190
If Cells(iRow, 2) = "Abnahme extern" Then
h = iRow
GoTo w16
End If
Next
w16:
For iCol = 7 To 190
If Cells(iRow, 2) = "Abnahme extern" And Cells(iRow, 4) = Cells(4, iCol) Then
Kommentar = Cells(iRow, 4).Comment.Text
Ende = iCol
GoTo e8
End If
Next
e8:
Range(Cells(h, Anfang), Cells(h, Ende)).Interior.ColorIndex = 46
With Cells(h, Ende)
On Error Resume Next
.Comment.Delete
.AddComment
.Comment.Text Text:=Kommentar
End With
Next

End Sub

MfG Zoe mit Dank im Voraus

Hallo,

MS-Projekt sagt mir was und arbeite ich auch mit. Es ist so wie ich bereits geschriben habe, dein Programm durchläuft den gesamten Bereich mehrere Male. für jeden Arbeitsschritt .

Ich würde die Abfragen, aus dem was mir jetzt bekannt ist, etwas anders aufbauen.

Ich werde dir mal meine Emailadresse, sehe mal im Pager nach, senden, dann kannst du mir eine Beispieldatei zukommen lassen.

Gruß

Helmut

Hallo,

habe mir gestern Abend die Tabelle mal angesehen, kann man, nach meiner Ansicht, einiges drin verkürzen. Dafür ist es aber erforderlich den Ablauf mal in Ruhe durchzugehen.

Gruß

Helmut

Hallo Helmut,

danke dir erstmal für deine Mühe. Wäre Klasse, wenn du mir dann kürzere Varianten der Makros senden könntest.

Findest 2 Mail- Adressen in deinem Pager.

Danke nochmal und schönen Tag noch

MfG Zoe

Hallo,

damit keiner meint die Lösung wäre geheim


Sub Abteilungen_Zeitbalken_färben()
Dim iRow As Long, iCol As Integer, Anfang As Integer, Ende As Integer, Farbe As Integer, _
Kommentar As String
On Error Resume Next
Letzte_Zeile = Range("B65536").End(xlUp).Row
Letzte_Spalte = Range("IV4").End(xlToLeft).Column
For iRow = 8 To Letzte_Zeile
If Cells(iRow, 2) = "Versand" Then Farbe = 19
If Cells(iRow, 2) = "Konstruktion" Then Farbe = 24
If Cells(iRow, 2) = "Einkauf" Then Farbe = 34
If Cells(iRow, 2) = "Mechanik" Then Farbe = 35
If Cells(iRow, 2) = "Elektrik" Then Farbe = 37
If Cells(iRow, 2) = "Montage beim Kunden" Then Farbe = 40
If Cells(iRow, 2) = "Abnahme intern" Then Farbe = 46
If Cells(iRow, 2) = "Abnahme extern" Then Farbe = 46
Anfang = 0
Ende = 0
Kommentar = ""
For iCol = 7 To Letzte_Spalte
If Cells(iRow, 3) = Cells(4, iCol) And Cells(iRow, 3) <> "" Then
Anfang = iCol
Exit For
End If
Next
For iCol = Anfang To Letzte_Spalte
If Cells(iRow, 4) = Cells(4, iCol) And Cells(iRow, 4) <> "" Then
Kommentar = Cells(iRow, 4).Comment.Text
Ende = iCol
Exit For
End If
Next
Range(Cells(iRow, Anfang), Cells(iRow, Ende)).Interior.ColorIndex = Farbe
With Cells(iRow, Ende)
.Comment.Delete
.AddComment
.Comment.Text Text:=Kommentar
End With
Next
End Sub


Gruß

Helmut

Hallo,

noch eine kürzere Fassung


Sub Abteilungen_Zeitbalken_färben()
Dim iRow As Long, iCol As Integer, Anfang As Integer, Ende As Integer, Farbe As Integer, _
Kommentar As String
On Error Resume Next
Letzte_Zeile = Range("B65536").End(xlUp).Row
Letzte_Spalte = Range("IV4").End(xlToLeft).Column
For iRow = 8 To Letzte_Zeile
Anfang = 0
Ende = 0
Kommentar = ""
Farbe = Cells(iRow, 2).Interior.ColorIndex
If Cells(iRow, 3) <> "" Then Anfang = Cells(iRow, 3).Value - Cells(4, 8).Value + 8
If Cells(iRow, 4) <> "" Then
Kommentar = Cells(iRow, 4).Comment.Text
Ende = Cells(iRow, 4).Value - Cells(4, 8).Value + 8
End If
Range(Cells(iRow, Anfang), Cells(iRow, Ende)).Interior.ColorIndex = Farbe
With Cells(iRow, Ende)
.Comment.Delete
.AddComment
.Comment.Text Text:=Kommentar
End With
Next
End Sub

diese funktioniert aber nur da wenn die Zellen in Spalte B farbig hinterlegt sind

Farbe = Cells(iRow, 2).Interior.ColorIndex

wie es hier der Fall ist

Gruß

Helmut

Hallo Helmut.

Danke und ich hab dir mal noch ne Mail geschickt.

MfG Zoe

Hallo @Zoe-Jane ,

in der Anfrage war geschrieben worden

meine Frage, gehts jetzt wesentlich schneller, da sonst alle Mühe für die Katz war.

nach meiner Ansicht müsste es ganz schön was gebracht haben.

Gruß

Helmut

• Mehrere Dateien zusammenfassen
• ca 2000 Excel Dateien in einer zusammenfassen
• Makros via Makro löschen
• Deaktivierte Makros in Word