Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1344to1348
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

Zeilen einer ExcelTabelle auf Knopfdrck. erweitern

Zeilen einer ExcelTabelle auf Knopfdrck. erweitern
14.01.2014 13:33:10
Peter
Hallo Leute,
ich habe eine ziemlich umfangreiche Exceltabelle, mit mehreren Spalten verschiedener Breite.
Gerne würde ich, das für einen neuen Auftrag, auf Knopfdruck 2 neue Zeilen nach dem Standartmuster hinzugefügt werden, dh. die Breite etc. des Formulares soll beibehalten bleiben.
Gibt es die Möglichkeit dies zu programmieren? Habt ihr mich richtig verstanden?
Ich habe ein Bild zum besserern Verständnis hinzugefügt.
Ich habe natürlich die Daten gelöscht.
Kurz zur Programmerklärung:
Ich habe das Progamm momentan so installiert, das jede zweite Zeile abgefragt wird (Report), denn dort wird ein Status angegeben, ob ein Test bestanden wurde oder nicht.
Es wird jeweils die Zweiten Zeilen abgefragt und dann der Reifegrad berechnet.
Nun ist es so, dass verschiedene Projekte vielen Zeilen benötigen und einige nur wenige. Ich habe das Programm momentan noch auf eine sehr große Tabelle aufgebaut. Das heißt selbst wenn ich nur eine Zeile abfragen muss, wird alles abgefragt.
Ich würde gerne Zeilen programmieren und gleichzeitig irgendwie mitzählen, sodass der Compiler weiß, bis wo er die Zeilen überprüfen muss. Dies hängt dann vom Projektumfang ab. Ich hoffe ihr wisst, was ich meine ansonten fragt bitte noch mal nach, ich antworte schnell!
Ich hoffe man kann dies irgendwie programmieren.
ich wäre euch sehr dankbar.
Frohes neues Jahr noch!
Userbild
Gruß Peter

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zeilen einer ExcelTabelle auf Knopfdrck. erweitern
14.01.2014 19:22:59
Hajo_Zi
Hallo Peter,
Du magst Ja glauben das jeder der Dein Bild in Excel öffnet die gleiche Tabelle siehst wie Du. Da irrst Du aber es ist keine Farbe und Code ist auch nicht vorhanden.
Ich baue keine Datei nach, die Zeit hat schon jemand investiert.
Ein Nachbau sieht bestimmt anders aus als das Original.
Ein Link zur Datei wäre nicht schlecht.
Mal ein Zitat von Hasso:
"Stell dir mal vor, deine Oma schreibt dir zum Geburtstag und sagt, die Geschenke findest du im Päckchen. Darin sind dann aber nur Bilder von den Geschenken - dann wärst du genauso begeistert wie wir jetzt."
Gruß Hajo

Anzeige
AW: Zeilen einer ExcelTabelle auf Knopfdrck. erweitern
15.01.2014 14:40:58
Peter
Hallo Hajo, okay.
Das ist der Code einer Tabelle:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("E10:AA140")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
' Alle Zähler auf 0 setzen
z1 = 0
z2 = 0
z3 = 0
z4 = 0
'Hintergrundfarbe aus Tabelle abfragen
For r = 8 To 140 Step 2
For s = 5 To 27
t = Cells(r, s).Interior.ColorIndex
Select Case t
Case 37:        z1 = z1 + 1     'Zähler für
Case 4:         z2 = z2 + 1     'Zähler für
Case -4142:     z3 = z3 + 1     'Zähler für
Case 3:         z4 = z4 + 1     'Zähler für
End Select
laenge = Len(Cells(r, s))
inhalt = Cells(r, s).Value
Next s
Next r
cellsoverall = (66 * 23)
relevantcells = cellsoverall - z1
'Anzahl der Zeilen in der Matrix
If z2 = 0 Or relevantcells = 0 Then
MsgBox "Please fill the cells with a status!"
reifegrad = 0
Else
reifegrad = (z2 / relevantcells) * 100
End If
'MsgBox reifegrad
Range("I1").Value = xxx
Range("D141").Value = xxx
Range("D142").Value = xxx
Range("D143").Value = xxx ' Status green
Range("D144").Value = xxx 'Status rot
Range("D145").Value = xxx ' unbearbeitete Zellen, Zellen ohne Status
MsgBox "Changed cell(s):  " & Selection.Address
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target = "Doubleclick to insert" & vbCrLf & "hyperlink" Then
On Error GoTo ErrExit
Application.EnableEvents = False
Cancel = True
Target = ""
If Application.Dialogs(xlDialogInsertHyperlink).Show = -1 Then
Else
Target = "Doubleclick to insert" & vbCrLf & "hyperlink"
End If
End If
ErrExit:
Application.EnableEvents = True
End Sub

Das ist der Code aus dem Modul:

Sub StatusGruen()
With Selection.Interior
.ColorIndex = 4
.Pattern = xlSolid
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.FormulaR1C1 = "Doubleclick to insert" & vbCrLf & "hyperlink"
With .Characters(Start:=1, Length:=2).Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
End Sub
Sub StatusRot()
With Selection.Interior
.ColorIndex = 3
.Pattern = xlSolid
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.FormulaR1C1 = "NOK"
With .Characters(Start:=1, Length:=2).Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
End Sub
Sub StatusNR()
With Selection.Interior
.ColorIndex = 37
.Pattern = xlSolid
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.FormulaR1C1 = "NR"
With .Characters(Start:=1, Length:=2).Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
End Sub
Sub StatusNoStatus()
With Selection.Interior
.ColorIndex = xlNone
End With
With Selection
.FormulaR1C1 = ""
End With
End Sub

Ich hoffe jetzt könnt ihr mir alle besser weiterhelfen.
Das Bild habe ich ja gepostet, wie die Tabelle in etwa aussieht.
Wird mein Problem, bzw mein Anliegen erkannt?
Danke.
Gruß PK

Anzeige
AW: Zeilen einer ExcelTabelle auf Knopfdrck. erweitern
15.01.2014 14:49:30
Hajo_Zi
ich bin dann raus, siehe meine erste Antwort.
Gruß Hajo

AW: Zeilen einer ExcelTabelle auf Knopfdrck. erweitern
15.01.2014 15:03:31
Peter
Hallo Hajo, okay.
Das ist der Code einer Tabelle:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("E10:AA140")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
' Alle Zähler auf 0 setzen
z1 = 0
z2 = 0
z3 = 0
z4 = 0
'Hintergrundfarbe aus Tabelle abfragen
For r = 8 To 140 Step 2
For s = 5 To 27
t = Cells(r, s).Interior.ColorIndex
Select Case t
Case 37:        z1 = z1 + 1     'Zähler für
Case 4:         z2 = z2 + 1     'Zähler für
Case -4142:     z3 = z3 + 1     'Zähler für
Case 3:         z4 = z4 + 1     'Zähler für
End Select
laenge = Len(Cells(r, s))
inhalt = Cells(r, s).Value
Next s
Next r
cellsoverall = (66 * 23)
relevantcells = cellsoverall - z1
'Anzahl der Zeilen in der Matrix
If z2 = 0 Or relevantcells = 0 Then
MsgBox "Please fill the cells with a status!"
reifegrad = 0
Else
reifegrad = (z2 / relevantcells) * 100
End If
'MsgBox reifegrad
Range("I1").Value = xxx
Range("D141").Value = xxx
Range("D142").Value = xxx
Range("D143").Value = xxx ' Status green
Range("D144").Value = xxx 'Status rot
Range("D145").Value = xxx ' unbearbeitete Zellen, Zellen ohne Status
MsgBox "Changed cell(s):  " & Selection.Address
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target = "Doubleclick to insert" & vbCrLf & "hyperlink" Then
On Error GoTo ErrExit
Application.EnableEvents = False
Cancel = True
Target = ""
If Application.Dialogs(xlDialogInsertHyperlink).Show = -1 Then
Else
Target = "Doubleclick to insert" & vbCrLf & "hyperlink"
End If
End If
ErrExit:
Application.EnableEvents = True
End Sub

Das ist der Code aus dem Modul:

Sub StatusGruen()
With Selection.Interior
.ColorIndex = 4
.Pattern = xlSolid
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.FormulaR1C1 = "Doubleclick to insert" & vbCrLf & "hyperlink"
With .Characters(Start:=1, Length:=2).Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
End Sub
Sub StatusRot()
With Selection.Interior
.ColorIndex = 3
.Pattern = xlSolid
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.FormulaR1C1 = "NOK"
With .Characters(Start:=1, Length:=2).Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
End Sub
Sub StatusNR()
With Selection.Interior
.ColorIndex = 37
.Pattern = xlSolid
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.FormulaR1C1 = "NR"
With .Characters(Start:=1, Length:=2).Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
End Sub
Sub StatusNoStatus()
With Selection.Interior
.ColorIndex = xlNone
End With
With Selection
.FormulaR1C1 = ""
End With
End Sub

Ich hoffe jetzt könnt ihr mir alle besser weiterhelfen.
Das Bild habe ich ja gepostet, wie die Tabelle in etwa aussieht.
Wird mein Problem, bzw mein Anliegen erkannt?
Danke.
Gruß PK
Anzeige

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige