VBA Code Erklärung

Guten Abend zusammen. Könnte mir jemand weiterhelfen bei diesem Code. Was macht er genau in Excel? Also Die einzelnen Schritte die er durchläuft,.

Option Explicit

Public Sub Double_Red()
Dim lngZeile As Long
Dim lngZeilenSprung As Long
Dim strSuchwert As String

lngZeile = Cells(Rows.Count, 4).End(xlUp).Row

  For lngZeilenSprung = lngZeile To 1 Step -1
    strSuchwert = Cells(lngZeilenSprung, 4).Value
      If Application.WorksheetFunction.CountIf(Range(Cells(1, 4), Cells(lngZeile, 4)), strSuchwert) <> 1 Then
        Cells(lngZeilenSprung, 4).Interior.ColorIndex = 3
      End If
  Next lngZeilenSprung

End Sub

2 Antworten

Vom Beitragsersteller als hilfreich ausgezeichnet

Iamiam

Von gutefrage auf Grund seines Wissens auf einem Fachgebiet ausgezeichneter Nutzer

Microsoft Excel

27.08.2012, 15:56

ausgehend von der letzten Zeile, Spalte4=D wird der letzte Eintrag gesucht und dessen Zeile in lngZeile festgehalten. Der Suchwert wird diesem Eintrag gleichgesetzt in strSuchwert

Nach oben wird nun JEDE (Step=-1) Zelle abgeprüft, ob =Zählenwenn(D1:D-letzterEintrag) Wiederholungen findet und diese dann rot eingefärbt.
Dabei ist zu beachten, dass auch mehrere leere Zellen als Wiederholung gesehen werden.
Im Prinzip geht es um die Markierung von Doppeln.

Anm: die Formulierung
For lngZeilenSprung = lngZeile To 1 Step -1
ist mir neu, aber sie funktioniert.

Tipp: füge vor der If-Zeile folgenden Code ein:
Debug.Print lngZeile & " " & lngZeilenSprung & " strSuchwert: " & strSuchwert

und nach End If dann zusätzlich noch
Debug.Print Application.WorksheetFunction.CountIf(Range(Cells(1, 4), Cells(lngZeile, 4)), strSuchwert)

Das druckt den jeweiligen Stand der Variablen bzw das Formelergebnis von Countif() [=Zählenwenn()] im "Direktfenster" aus, so dass Du Schleife für Schleife die Entwicklung verfolgen und Fehler finden kannst!

Sinnvoll könnte auch sein, die Definition
strSuchwert = Cells(lngZeile, 4).Value
zu setzen, dann würde nur der letzte Eintrag auf die Existenz eines Doppels geprüft.

Iamiam

27.08.2012, 16:09

vergiss den letzten Absatz, da hab ich mich vertan!. Dazu müsste man wohl eine weitere Variable einführen.

P0wd3r

Beitragsersteller

27.08.2012, 23:44

Wow! Vielen Dank genau so hab ich es mir vorgestellt hat mir sehr geholfen =)

Iamiam

28.08.2012, 00:18

@P0wd3r

gern geschehen, sowas ist wie Kreuzworträtsel lösen oder Sudoku!
Und danke für den *
Mit debug.print kannst Du übrigens recht komplizierte Abfolgen recht genau auflösen! Sehr nützlich!

Iamiam

28.08.2012, 00:52

@Iamiam

interessant ist bei diesem Code auch, dass
lngZeile = Cells(Rows.Count, 4).End(xlUp).Row
nur eine gedachte Cursorbewegung ist, keine wirkliche (da wird nichts ausgewählt, aktiviert oder versetzt. So gehts am schnellsten!).
Ich bevorzuge allerdings der Klarheit wegen genauere Bezeichnungen, zB.
Activesheet.Cells(...,...).End(xlUp).row

Dazu noch eine Besonderheit: es heißt:

.End(xlToRight) und .End(xlToLeft), aber wieder .End(xldown),

weil nämlich xlLeft und xlTop schon belegt sind für anderes.
Die Hilfe bieter nur recht dürftige Auskunft zu solchen ähnlich-Fragen und gar keine zu Gegensatz- bzw invers-Ausdrücken!

heilwigkenner

26.08.2012, 19:51

Ich würde sagen, er überspringt eine Zeile oder schreibt etwas in eine Zeile.

Ähnliche Beiträge

VBA CODE Zellen nach bestimmten Textinhalt suchen und Zeile Färben?

Hallo, kann mir bitte jemanden mit dem Code behilflich sein?

Dieser Code sucht die Zellen in Spalte"A" nach bestimmten Textinhalt ab und bei Treffer löscht er die zughörige gesamte Zeile. Meine Frage: kann man diesen Code so ändern, dass anstatt die gefundene Zeile zu löschen nur mit einer Farbe z.B. Orange (44) färbt? Vielen Dank im Voraus.

Sub zeilenloeschen()
  Dim i As Long
  Dim letzteZeile As Long
  Dim suchBereich As Range
  Dim gefunden As Range
  Dim ersterTreffer As String
  Dim suchWert As String
  suchWert = "1" 'hier kommt dein Suchwert rein
  
  With ThisWorkbook.Sheets("Sheet4")
    letzteZeile = .Range("A" & Rows.Count).End(xlUp).Row
    Set suchBereich = .Range("A1:A" & letzteZeile)
    Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart)
    If Not gefunden Is Nothing Then
      ersterTreffer = gefunden.Address
      Do
        gefunden.Activate
        ActiveCell.EntireRow.Delete shift:=xlUp
        Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart)
      Loop While Not gefunden Is Nothing
    End If
  End With
End Sub

...zum Beitrag

Excel: Verbessertes Logging mit VBA Makro?

Hallo Zusammen

ich verwende im Moment ein kurzes Makro, um Änderungen in einem Tabellenblatt zu loggen.

Es registriert aber nur einzelne Änderungen, nicht multi-selektion oder Löschen von Spalten. Kann ich das mit separaten Privaten Subs übernehmen?

Und kann ich aufnehmen, was die Target- und "PreVal"-Adresse war (Offset 4+5)

Code:

Dim PreVal
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
PreVal = Target.Value
 
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
  
    On Error GoTo 0
    
    If Target.Value <> PreVal Then
        With Sheets(2).Cells(Rows.Count, 1).End(xlUp)
            .Offset(1, 0) = Now
            .Offset(1, 1) = PreVal
            .Offset(1, 2) = Target.Value
            .Offset(1, 3) = Environ("Username")
        End With
    End If
 
End Sub

...zum Beitrag

Excel, Userform: Datum aus Textbox wird in der Zelle nicht als Datum erkannt?

Ich habe folgenden Code:

Private Sub Fertig_Click()

Dim last As Integer

last = Tabelle1.Cells(Rows.Count, 1).End(xlUp).Row + 1

Tabelle9.Cells(last, 1) = Format(Eingabe.Antragsdatum.Value, "dd.mm.yyyy")

End Sub

In der Zelle nachher wird es nicht als Datum erkannt.
Muss es aber als Datum sortieren können.

Ich habe schon viele Foreneinträge zu dem Thema gelesen, doch nichts davon funktioniert bei mir.

...zum Beitrag

VBA: Zwei Spalten mit Wert multiplizieren und dann addieren mit Hilfe von Makros

Hallöchen,

ich habe folgendes Problem Ich habe zwei Spalten die ich jeweils miteinander addieren möchte. Doch bevor ich diese addiere, möchte ich Spalte B mit dem Wert aus der TextBox1 multiplizieren und Spalte C mit dem Wert aus Textbox2. Danach sollen beide Spalten miteinander addiert und dann sortiert werden. Spalte D ist in diesem Fall die Ergebnisspalte. Das Programm hat auch schon funktioniert, jedoch habe ich vorher nur die spalten addiert und sortiert.

HIer mein bereits geschriebener Code:

Private Sub CommandButton1_Click()



' Prüfen ob Lastspitzen eingetragen wurden, ansonsten Fehlermeldung

        If TextBox1.Value = "" Or TextBox2.Value = "" Then
        MsgBox "Bitte geben Sie eine Lastspitze ein!"
     
Else
        
Dim wks As Excel.Worksheet
Dim lngLetzteZeile As Long
Dim Last1 As Integer
Dim Last2 As Integer
Last1 = TextBox1.Value
Last2 = TextBox2.Value  

Set wks = ActiveWorkbook.Worksheets("Vergleich")


With wks
 
lngLetzteZeile = .Cells(.Rows.Count, "B").End(xlUp).Row
If lngLetzteZeile < 15 Then Exit Sub

 With .Range("D15:D" & lngLetzteZeile)
 'berechne: D := B + C
 .FormulaR1C1 = "=RC[-2]*Last1+RC[-1]*Last2"
 'Formeln durch deren Ergebnis ersetzen
 .Value = .Value
 End With
 
With .Range("B15:D" & lngLetzteZeile)
 .Sort Key1:=.Cells(2), Order1:=xlDescending, _
 DataOption1:=xlSortTextAsNumbers, _
 SortMethod:=xlPinYin
End With

End With
End If


End Sub

...zum Beitrag

[VBA] - Multipage Userform eingaben in Excel übertragen?

Servus Leute,

Ich habe ein Userform in Excel mit Multipage erstellt.

Nun möchte ich auf der letzten Multipage Seite einen Button einbauen. Auf Knopfdruck sollen dann alle Eingaben die vom User auf den einzelnen Multipageseiten gemacht worden sind in ein Excel Tabellenblatt übertragen werden.

Mein Ansatz war dem Button folgenden Code zu geben:

    Dim sheet2 As Worksheet
    Dim maxRow2 As Long
    Dim check3 As Boolean
    Set sheet2 = ActiveWorkbook.Worksheets(1)
    maxRow2 = sheet2.Cells(sheet2.Rows.Count, "B").End(xlUp).Row
    If CheckBox1.Value Then
      sheet2.Cells(maxRow2 + 1, 9).Value = "ja"
      Else
        sheet2.Cells(maxRow2 + 1, 9).Value = "nein"
        End If
              sheet2.Cells(maxRow2 + 1, 13).Value = TextBox4.Value

Das funktioniert leider nicht wie ich es mir erhofft habe, auf Knopfdruck werden keine Daten übertragen. Ich habe die vermutung, dass nicht auf die Felder wie z.B. TextBox4 zugegriffen werden kann, weil die auf einer anderen Seite im Multipage sind.

Wie schaffe ich es an die Variablen ranzukommen. Ich hatte noch überlegt, im Code der jeweiligen Seite den Wert aus der Textbox in eine Variable zu setzen, die z.B. Global ist. Aber da bin ich auch schon wieder überfragt wie man das macht.

Außerdem habe ich noch eine Frage zu den Checkboxen.

Es soll folgende Möglichkeiten geben:

Wenn Checkbox nicht angeklickt, dann kann man immer zu nächsten Kategorie ( Nächste Seite im Multipage)
Wenn Checkbox angeklickt ist und variable x leer, dann soll man nicht weiter kommen (Msgbox)
Wenn Checkbox angeklickt ist und variable x befüllt, dann kann man zur nächsten Kategorie (Nächste Seite im Multipage)

Für eine Checkbox habe ich das schon hinbekommen, aber wie mach ich das wenn es mehrere Checkboxen gibt. Weil ich glaube wenn ich das so mache wie bisher, dann wird das eine endlose anreihung von if bedingungen.

Diesen Code habe ich dann auf den Button gelegt, mit dem man zur nächsten Kategorie kommen soll oder eben halt nicht.

  Dim sheet2 As Worksheet
    Dim maxRow2 As Long
    Dim check3 As Boolean
    Set sheet2 = ActiveWorkbook.Worksheets(1)
    maxRow2 = sheet2.Cells(sheet2.Rows.Count, "B").End(xlUp).Row
   
    If CheckBox3.Value Then
    If Test = False Then
    MsgBox ("Kein Pfad angegeben")
    Else
  Dim iNextPage As Long
    With Me.MultiPage1
        iNextPage = .Value + 1
        If iNextPage < .Pages.Count Then
            .Pages(iNextPage).Visible = True
            .Value = iNextPage
        End If
    End With
    End If
    Else
    Dim iNextPage2 As Long
    With Me.MultiPage1
        iNextPage2 = .Value + 1
        If iNextPage2 < .Pages.Count Then
            .Pages(iNextPage2).Visible = True
            .Value = iNextPage2
        End If
    End With
    End If

Und als letztes würde ich gern noch wissen ob es möglich ist, zu unterbinden, dass der User oben im Multipage die Kategorie direkt anklicken kann und man halt nur über den "weiter" button zur nächsten kategorie kommt.

Gruß Chris

...zum Beitrag

Excel: Wie gestalte ich dieses Makro schneller und effektiver und sorge dafür, dass es bei Neustart nur neue Werte erkennt?

Wie kann ich dieses Makro schneller und effektiver machen und wie bekomme ich es hin, dass es beim Neustart nicht schon wieder die Werte erkennt, die schon einmal dran waren? Sodass die 50 nach dem ersten Mal Abspielen des Sounds ignoriert wird.

Code:

Sub PlaySound()
  Dim ws As Worksheet
  Dim rng As Range
  Dim cell As Range
  Dim goals As Long
  Dim soundFile As String
  Dim thresholds As Variant
  Dim i As Integer
  Set ws = ThisWorkbook.Worksheets("Spielplan")
  Set rng = ws.Range("O1:O" & ws.Cells(ws.Rows.Count, "O").End(xlUp).row)
  soundFile = "Sound_pfad.mp3"
  'Array of threshold values
  thresholds = Array(50, 100, 150, 200, 250, 300, 350, 400, 450, 500,550,600,650,700,750,800,850,900,950,1000)
  Do While True 'Endlosschleife hinzugefügt
    For Each cell In rng
      If IsNumeric(cell.Value) Then
        goals = goals + cell.Value
        'Check if goals is equal to any of the threshold values
        For i = LBound(thresholds) To UBound(thresholds)
          If goals = thresholds(i) Then
            Application.ScreenUpdating = False
            Application.EnableEvents = False
            ActiveSheet.OLEObjects.Add(Filename:=soundFile, Link:=False, DisplayAsIcon:=False).Select
            Selection.Verb Verb:=xlPrimary
            Selection.Delete
            Application.ScreenUpdating = True
            Application.EnableEvents = True
          End If
        Next i
      End If
    Next cell
    'Verzögerung hinzugefügt, um die CPU-Auslastung zu reduzieren
    Application.Wait (Now + TimeValue("0:05:00"))
  Loop
End Sub

...zum Beitrag

An Bedingungen gebundenes ausblenden von Zeilen?

Ich habe ein Problem, welches ich alleine nicht schaffe zu lösen.

Ich habe eine Exceltabelle mit einem Button "Closed ausblenden".
Bisher funktioniert es soweit, dass er alle in Spalte N "Closed" ausblendet.

Code ist bis jetzt so:

Private Sub ToggleButton4_Click()

If Me.ToggleButton4.Value = True Then

Dim Liste As Range

Dim lngCriteriaCount As Long

Dim arrCriteria() As String

Dim oLO As ListObject

Application.EnableEvents = True

For r = 3 To ActiveSheet.UsedRange.Rows.Count

If InStr(Cells(r, 14).Value, "CLOSED") Then

Rows(r).RowHeight = 0

End If

Next

Me.ToggleButton4.Caption = "'CLOSED' ausgeblendet"

Else

For l = 3 To ActiveSheet.UsedRange.Rows.Count

If InStr(Cells(l, 14).Value, "CLOSED") Then

Rows(l).RowHeight = 12

End If

Next

Me.ToggleButton4.Caption = "'closed' ausblenden"

End If

End Sub

Nun soll es erweitert werden:
Es soll nicht nur die Zeile sondern auch alle nachfolgenden Zeilen ausgeblendet werden - bis das Wort "Topic" oder "Topic ll" erreicht wird.

In diesem Beispiel also das gelb markierte mit ausblenden.

Kann mir jemand helfen?

...zum Beitrag

Hallo, ich möchte in einer Excel Datei per vba code bis zur ersten leeren zeile gehen, wie tue ich das?

ich möchte zur ersten leeren Zeile gehen und dann den rest markieren und löschen, also den kompletten Bereich ab da? BSp. A10 ist leer, dann möchte ich ab A10:z10 und abwärts alles markieren und löschen

Wie??

Sub FIND_EMPTY_CELL()

    Dim zeil As Integer
    Dim z As Integer
    Dim leerAbWo As Long

    zeil = ActiveSheet.UsedRange.Rows.Count 'letzte ausgefüllte Zeile

    For z = 8 To zeil

            If Cells(z, 1) = "" Then
                'leere Zelle gefunden
                leerAbWo = Cells(z, 1).Select 'gefundene Zelle selektieren
                'jetzt ab da an bis AA markieren und rest löschen!!!
                MsgBox leerAbWo
                Exit Sub
            End If
    Next z
End Sub

...zum Beitrag

Name + User?

Hallo,

was müsste ich hier anpassen? Ich komme mit der Fehler Meldung nicht zurecht.

Private Declare 36 GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Function GetNTUserA() As String
  
 Dim sBuffer As String
 Dim LSize As Long
 Dim user As String
  
 sBuffer = Space$(255)
 LSize = Len(sBuffer)
  
 Call GetUserName(sBuffer, LSize)
  
 If LSize > 0 Then
  user = Left$(sBuffer, LSize - 1)
 Else
  user = vbNullString
 End If
  
 GetNTUserA = user
  
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
   
    If Target.Column = 6 Then
    Target.Offset(0, 11).Value = Date
  End If
      
    If Target.Column = 6 Then
    Target.Offset(0, 10).Value = GetNTUserA
  End If

End Sub

...zum Beitrag

Tabellen mit vba nebeneinander anstatt untereinander anordnen?

Hallo,

ich habe bereits meine Excel-Arbeitsmappe bestehend aus 250 Seiten mit jeweils 2Spalten und 250 Zeilen via vba zusammengeführt.

Allerdings wird dabei alles untereinander dargestellt und nicht nebeneinander. Kann man es so machen, dass sobald ein Worksheet abgearbeitet wurde und angezeigt wird, das nächste daneben in der Spalte beginnen lässt und immer so weiter.

Gibt es Möglichkeiten dort eine Art „Cut“ zu machen?

Sub Konsolidieren()
Dim Wks As Worksheet
Dim Bereich As Range
Dim strLC As String
Dim i As Integer
Set Wks = Worksheets.Add
Wks.Name = "Gesamt"
For i = 2 To Worksheets.Count
 With Worksheets(i).UsedRange
 strLC = .Cells(.Rows.Count, .Columns.Count).Address
 Set Bereich = .Range("A1:" & strLC)
 Bereich.Copy Destination:= _
 Wks.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
 End With
Next i
End Sub

...zum Beitrag

VBA MSG BOX Titel nur aufzählen wenn Spalte "L" bestimmter Text?

Hallo zusammen,

ich komme bei diesem Code nicht weiter. Die Msgbox soll nur die Zeilen auflisten wenn ihn Spalte "L" der Text "offen" vorkommt. Kann mir dabei jemand bitte behilflich sein?

Private Sub Workbook_Open()

Dim rDatWartung

Dim sMsgBaldFaellig As String

Dim sMsgUeberFaellig As String

sMsgBaldFaellig = ""

sMsgUeberFaellig = ""

lz = Cells(Rows.Count, 5).End(xlUp).Row

For Each rDatWartung In Range("D30:D600")

If rDatWartung.Value <> "" Then

If rDatWartung.Value <= Date + 7 Then

sMsgUeberFaellig = sMsgUeberFaellig & Cells(rDatWartung.Row, 4) & " " & vbCrLf & Cells(rDatWartung.Row, 6)

Else

If rDatWartung.Value <= Date + 14 Then _

sMsgBaldFaellig = sMsgBaldFaellig & Cells(rDatWartung.Row, 4) & " " & Cells(rDatWartung.Row, 4) & vbCrLf

End If

If sMsgUeberFaellig & sMsgBaldFaellig <> "" Then

MsgBox "Überfällig" & vbCrLf & " " & sMsgUeberFaellig

End If

End Sub

Herzlichen Dank, und einen schönen Abend

...zum Beitrag

Excel VBA - Darstellung waagerecht-vertikal beim kopieren ändern?

Hallo,

ich habe in einer fertigen Tabelle etwas geändert, um die Eingabe der Daten zu erleichtern. Statt die Daten in der Spalte zu erfassen, werden die Daten jetzt in einer Zeile eingegeben.

Also statt vorher in B10, B11, B12... jetzt in B10, C10, D10...

Die Daten werden mit Hilfe eine Makros in eine andere Tabelle transferiert und waagerecht eingefügt.

Da ich aber die Eingabeart verändert habe, werden die Daten jetzt untereinander in die Tabelle eingefügt.

Ich weiß, dass das mit "Application.Transpose" zu tun hat.

Nun weiss ich aber nicht wie ich die Zeile umbenennen muss, damit die waagerechte Darstellung übernommen wird.

Wie ändere ich die Zeile, damit die angesprochenen Werte waagerecht in die Zeile kopiert werden?

Hier der komplette Code:

Sub transfer_werte()
    Dim rngKunde    As Excel.Range
    Dim rngReklam   As Excel.Range
    Dim rngArtikel   As Excel.Range

     Set rngKunde = Worksheets("Eingaben").Range("C5:C10")
    Set rngReklam = Worksheets("Eingaben").Range("D5:D9")
    Set rngArtikel = Worksheets("Eingaben").Range("C14:L14")
   
        With Worksheets("Liste")
          With .Cells(.Rows.Count, 2).End(xlUp)
               .Offset(1, 0).Resize(rngKunde.Columns.Count, rngKunde.Rows.Count).Value = Application.Transpose(rngKunde.Value)
        End With
    End With
   
    With Worksheets("Liste")
        With .Cells(.Rows.Count, 8).End(xlUp)
             .Offset(1, 0).Resize(rngReklam.Columns.Count, rngReklam.Rows.Count).Value = Application.Transpose(rngReklam.Value)
        End With
    End With
  
   With Worksheets("Liste")
        With .Cells(.Rows.Count, 14).End(xlUp)
             .Offset(1, 0).Resize(rngArtikel.Columns.Count, rngArtikel.Rows.Count).Value = Application.Transpose(rngArtikel.Value)
        End With
    End With
      
End Sub

...zum Beitrag

VBA Makro Excel Letzte beschriebene Zeile vor Leerzeile, weitere Leerzeile einfügen

Guten Tag,

ich suche einen Code für ein Makro,dass in Spalte B unter der letzten beschriebenen Zelle vor einer leeren Zelle (also nicht am kompletten Ende des Sheets) eine Leerzeile einfügt. Habe schon etliche codes ausprobiert, zb

Sub letzte_Zeile()

'letzte benutzte Zelle in Spalte 2 finden DIM Ende As Long With ActiveSheet

Ende = .Cells(Rows.Count, 2).End(xlUp).Row End With

End Sub

Dieser sollte mir eig die letzte beschriebene Anzeigen,es funktioniert aber Garnichts.

Freue mich über Vorschläge. Viele Grüße

...zum Beitrag

Excel VBA eine große Menge leere Zeilen löschen?

Hallo, ich lade eine menge Datensätze in eine Tabelle rein und dabei werden auch die leeren Zeilen zwischendurch mal reinkopiert. Diese möchte ich nun entfernen. Das gelingt mir mittlerweile auch. Das Problem ist, dass es zu lange dauert bei ca. 2800 leere Zeilen, da diese einzeln angeschaut werden und gelöscht. Mein bisheriger Code:

Function loescheLeerenBereichn()

Dim Zelle As Long
Dim LetzteZeile As Long
LetzteZeile = Sheets("Lieferung").UsedRange.SpecialCells(xlCellTypeLastCell).Row
For Zelle = LetzteZeile To 7 Step -1 ' In Range(Cells(7, 4), Cells(LetzteZeile, 4))
If Cells(Zelle, 3) = "" Or Cells(Zelle, 3) = "." Then
Rows(Zelle).EntireRow.Delete Shift:=xlUp 
End If
Next Zelle

End Function

Wie kann man das schneller programmieren?

...zum Beitrag

Was möchtest Du wissen?

Deinen Beitrag erstellen