Excel vba wenn in Spalte A2, A3 usw. Zahl oder Text eingetragen wird

Question

Hallo guten Abend, brauche wieder eure Hilfe.

Ich benutze Excel 365 und es sollte, sobald in Spalte A2, A3 usw. eine Zahl oder Text eingetragen wird, so weit wie in Spalte A2, A3 usw. etwas enthalten ist, in Spalte H2, H3 usw. die Formel =WENN(ZÄHLENWENN($I$2:I2;I2)=1;ZÄHLENWENN(I:I;I2);"") und in Spalte i2, i3 usw. die Formel = WENN(B2="";"";B2&"  "&C2&"  "&E2) automatisch per vba eingetragen werden. Wenn möglich bitte den kompletten vba anzeigen da ich mich nicht so gut auskenne. Alles in der Tabelle “Alle Teilnehmer“.  Vielen Dank.

Answer 1

Hi

ich weiß nicht, ob ich dich richtig verstanden habe - folgenden Code ins Codemodul der Tabelle "Alle Teilnehmer":

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngZelle As Range
    If Target.Column = 1 And Target.Row > 1 Then
        For Each rngZelle In Intersect(Target, Columns(1))
            rngZelle.Offset(0, 8).Formula = "=IF(COUNTIF($I$2:I" & rngZelle.Row & ",I" & _
                rngZelle.Row & ")=1,COUNTIF(I:I,I" & rngZelle.Row & "),"""")"
            rngZelle.Offset(0, 9).Formula = "=IF(B" & rngZelle.Row & "="""","""",B" & _
                rngZelle.Row & "&""  ""&C" & rngZelle.Row & "&""  ""&E" & rngZelle.Row & ")"
        Next rngZelle
    End If
End Sub

Bis später, Karin

Answer 2

Hallo Karin, vielen Dank für die schnelle Antwort.

Habe die zwei Spaltennummern geändert (ROT), jedoch dauert das makro bei 200 Teilnehmer zu lange und wenn Teilnehmer gelöscht werden schmiert Excel ab. Ich glaube es wäre besser ein Makro mit Steuerelement nach eingabe aller Daten. Wäre das möglich und wie würde das aussehen.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngZelle As Range
    If Target.Column = 1 And Target.Row > 1 Then
        For Each rngZelle In Intersect(Target, Columns(1))
            rngZelle.Offset(0, 7).Formula = "=IF(COUNTIF($I$2:I" & rngZelle.Row & ",I" & _
                rngZelle.Row & ")=1,COUNTIF(I:I,I" & rngZelle.Row & "),"""")"
            rngZelle.Offset(0, 8).Formula = "=IF(B" & rngZelle.Row & "="""","""",B" & _
                rngZelle.Row & "&""  ""&C" & rngZelle.Row & "&""  ""&E" & rngZelle.Row & ")"
        Next rngZelle
    End If
End Sub

Answer 3

Hi,

der Code ist auch nicht für 200 Zellen gleichzeitig gedacht sondern dafür, wenn in Spalte A eine Eingabe erfolgt - und das tut man normalerweise nur für EINE Zelle. Dass er über mehrere Zellen läuft ist nur eine Vorsichtsmaßnahme, da es schließlich passieren kann, dass versehentlich mehrere Zellen gleichzeitig ausgewählt werden und dann würde ein Laufzeitfehler ausgelöst, weil "Target" auf 1 Zelle ausgerichtet ist.

Du hattest nicht geschrieben, dass auch Daten gelöscht werden können... Den Laufzeitfehler kann man aber durch die folgende Codeänderung umgehen:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngZelle As Range
    If Target.Column = 1 And Target.Row > 1 Then
        If Target.Cells(1) <> "" Then '<== nur wenn ein Eintrag erfolgt
            For Each rngZelle In Intersect(Target, Columns(1))
                rngZelle.Offset(0, 7).Formula = "=IF(COUNTIF($I$2:I" & _
                    rngZelle.Row & ",I" & rngZelle.Row & _
                    ")=1,COUNTIF(I:I,I" & rngZelle.Row & "),"""")"
                rngZelle.Offset(0, 8).Formula = "=IF(B" & rngZelle.Row & _
                    "="""","""",B" & rngZelle.Row & "&""  ""&C" & rngZelle.Row & _
                    "&""  ""&E" & rngZelle.Row & ")"
            Next rngZelle
        End If
    End If
End Sub

Wenn du die Formel unbedingt erst nach Abschluss aller Einträge in Spalte A übertragen willst, was m.E. nicht sinnvoll erscheint, da man das ja gleich bei Eintrag in jede Zelle der Spalte A erledigen kann, kannst du das mit folgendem Makro:

Sub FormelnEintragen()
    Dim lngLetzte As Long
    lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
    Cells(2, 7).Formula = "=IF(COUNTIF($I$2:I2,I2)=1,COUNTIF(I:I,I2),"""")"
    Cells(2, 8).Formula = "=IF(B2="""","""",B2&""  ""&C2&""  ""&E2)"
    Range("G2:H2").AutoFill Destination:=Range(Cells(2, 7), Cells(lngLetzte, 8)), Type:=xlFillDefault
End Sub

Bis später, Karin

Answer 4

Hallo Karin vielen Dank, genau was ich brauche da teilweise bis zu 250 Namen zugleich aus eine anderen Datei als Werte eingefügt werden.

Sub FormelnEintragen()
    Dim lngLetzte As Long
    lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
    Cells(2, 8).Formula = "=IF(COUNTIF($I$2:I2,I2)=1,COUNTIF(I:I,I2),"""")"
    Cells(2, 9).Formula = "=IF(B2="""","""",B2&""  ""&C2&""  ""&E2)"
    Range("i2:H2").AutoFill Destination:=Range(Cells(2, 8), Cells(lngLetzte, 9)), Type:=xlFillDefault
End Sub

Jetzt bräuchte ich noch in Spalte J2, J3 usw. Textausrichtung MITTE und Zellenfarbe GRAU mit Rahmenfarbe DUNKELGRAU. Alles im selben makro. Danke
Habe das markierte wieder zurückgestellt.

Answer 5

Hi,

Sub FormelnEintragen()
    Dim lngLetzte As Long
    lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
    Cells(2, 8).Formula = "=IF(COUNTIF($I$2:I2,I2)=1,COUNTIF(I:I,I2),"""")"
    Cells(2, 9).Formula = "=IF(B2="""","""",B2&""  ""&C2&""  ""&E2)"
    With Range("H2:I2")
        .HorizontalAlignment = xlCenter
        .Interior.Color = 11184814
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Color = 1447446
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Color = 1447446
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Color = 1447446
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Color = 1447446
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Color = 1447446
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Color = 1447446
            .Weight = xlThin
        End With
        .AutoFill Destination:=Range(Cells(2, 8), Cells(lngLetzte, 9)), Type:=xlFillDefault
    End With
End Sub

Bis später, Karin

Answer 6

Hallo Karin.

Jetzt bräuchte ich noch in Spalte J2, J3 usw. Textausrichtung MITTE und Zellenfarbe GRAU mit Rahmenfarbe DUNKELGRAU. Alles im selben makro. Das mit den Spalten H und i passt wie erster beschrieben. Danke

Answer 7

Hi,

dazu musst du nur 2 Zeilen ändern - erstens diese:

With Range("H2:J2")

und zweitens diese:

.AutoFill Destination:=Range(Cells(2, 8), Cells(lngLetzte, 10)), Type:=xlFillDefault

Bis später, Karin

Answer 8

Hallo Karin guten Tag, habe mich wohl nicht richtig ausgedrückt, die Formel für H2 und i2 passen genau nur in Spalte J2, J3 usw. stehen schon Daten, es sollen keine Daten gelöscht werden sondern nur die Spaltenfarbe (hellgrau) und der Spaltenrahmen unten und oben (grau) gemacht werden. Das alles im selben Makro. Vielen Dank.

Answer 9

Hi,

sorry, das hatt ich nicht so verstanden.

Sub FormelnEintragen()
    Dim lngLetzte As Long
    lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
    Cells(2, 8).Formula = "=IF(COUNTIF($I$2:I2,I2)=1,COUNTIF(I:I,I2),"""")"
    Cells(2, 9).Formula = "=IF(B2="""","""",B2&""  ""&C2&""  ""&E2)"
    Range("H2:I2").AutoFill Destination:=Range(Cells(2, 8), Cells(lngLetzte, 9)), Type:=xlFillDefault
    With Range("H2:J2")
        .HorizontalAlignment = xlCenter
        .Interior.Color = 11184814
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Color = 1447446
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Color = 1447446
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Color = 1447446
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Color = 1447446
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Color = 1447446
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Color = 1447446
            .Weight = xlThin
        End With
        .AutoFill Destination:=Range(Cells(2, 8), Cells(lngLetzte, 10)), Type:=xlFillFormats
    End With
End Sub

Bis später, Karin

Answer 10

Hallo Karin guten Tag, habe mich wohl NOCH nicht richtig ausgedrückt, die Formel für H2 und i2 sollen so bleiben wie hier angegeben. Es sollte die Spalte Spalte J2, J3 usw. wie unten beschrieben dazukommen

Sub FormelnEintragen()
    Dim lngLetzte As Long
    lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
    Cells(2, 7).Formula = "=IF(COUNTIF($I$2:I2,I2)=1,COUNTIF(I:I,I2),"""")"
    Cells(2, 8).Formula = "=IF(B2="""","""",B2&""  ""&C2&""  ""&E2)"
    Range("G2:H2").AutoFill Destination:=Range(Cells(2, 7), Cells(lngLetzte, 8)), Type:=xlFillDefault
End Sub

 In Spalte J2, J3 usw. stehen schon Daten, es sollen keine Daten gelöscht werden sondern nur die Spaltenfarbe in Spalte J2, J3 usw. (hellgrau) und der Spaltenrahmen unten und oben (grau) gemacht werden. Bei der letzten version werden auch bei den Spalten H und i die Farbe und Rahmen unten oben links und rechts geändert, die sollten nicht geändert werden. Vielen Dank.