Hallo zusammen, ich hoffe dass jemand helfen kann weil ich weiß nicht weiter, danke. Ich habe folgenden Code zum Suchen der Doppeltwerten in Spalte B und dann Löschung der Zeile: Sub DoppelteZeilenLoeschen() Dim letzteZeile As Long Dim Zeile As Long letzteZeile = Range("B" & Rows.Count).End(xlUp).Row For Zeile = letzteZeile To 1 Step -1 If WorksheetFunction.CountIf(Range("B1:B" & Zeile), Range("B" & Zeile)) > 1 Then Rows(Zeile).EntireRow.Delete End If Next End Sub Jetzt meine Frage: Was ich kann ich ergänzen, dass eine zweite Bedingung hier abgefragt wird vor der Löschung, also wenn Spalte "B" doppelwert hat dann Spalte "J" vergleichen, wenn Ergebnis der Spalte "J" gleich ist dann Zeile löschen, ansonsten weiter zählen. Ein Bsp. Spalte B Spalte J ABCD 1234 ABCD 1234 ABCD 4567 Hier sollten nur Zeile2 gelöscht werden. Vielen Dank im Voraus

Doppelte Werte suchen mit zusätzliche Bedingung dann eins löschen?

Hallo zusammen, ich hoffe dass jemand helfen kann weil ich weiß nicht weiter, danke.

Ich habe folgenden Code zum Suchen der Doppeltwerten in Spalte B und dann Löschung der Zeile:

Sub DoppelteZeilenLoeschen()

Dim letzteZeile As Long

Dim Zeile As Long

letzteZeile = Range("B" & Rows.Count).End(xlUp).Row

For Zeile = letzteZeile To 1 Step -1

If WorksheetFunction.CountIf(Range("B1:B" & Zeile), Range("B" & Zeile)) > 1 Then

Rows(Zeile).EntireRow.Delete

End If

End Sub

Jetzt meine Frage:

Was ich kann ich ergänzen, dass eine zweite Bedingung hier abgefragt wird vor der Löschung, also wenn Spalte "B" doppelwert hat dann Spalte "J" vergleichen, wenn Ergebnis der Spalte "J" gleich ist dann Zeile löschen, ansonsten weiter zählen.

Ein Bsp.

Spalte B Spalte J

ABCD 1234
ABCD 1234
ABCD 4567

Hier sollten nur Zeile2 gelöscht werden.

Vielen Dank im Voraus

3 Antworten

Oubyi, UserMod Light

Von gutefrage auf Grund seines Wissens auf einem Fachgebiet ausgezeichneter Nutzer

Microsoft Excel

29.05.2020, 15:05

Mal ein "WorksheetFunction.SumProduct".
Mit Countif wirst Du das nicht hinbekommen. Ohne VBA, also als Formel im Blatt, würde das in etwa so aussehen:

=SUMMENPRODUKT(((B1:B1000&J1:J1000)=(B1&J1))*1)>1

Das wäre die

WorksheetFunction.SumProduct

Da Du recht fit in VBA zu sein scheinst, kannst Du das eventuell ja selber umsetzten.
Ich muss jetzt leider zur Arbeit, schaue aber spätestens morgen wieder rein und helfe weiter, falls nötig.

Woher ich das weiß:Berufserfahrung – IT-Administrator (i.R.)

lokke526

Beitragsersteller

30.05.2020, 07:47

Sieht viel versprechend aus, bin gerade bei der arbeit, würde ich später testen und berichten. Besten Dank.

lokke526

Beitragsersteller

29.05.2020, 16:33

Danke dir Oubyi für die schnelle Antwort. Die Formel funktioniert, nur wie bringe ich das als Code rein? :)

Also alles was mit Ergebnis "Falsch" darf bleiben, "Wahr" sollte gelöscht werden.

Oubyi, UserMod Light

30.05.2020, 02:32

@lokke526

Mit WorkSheetFunction habe ich es irgendwie nicht hinbekommen. Bin aber beim "Stöbern" auf Evaluate gestoßen. Schau mal, ob es so klappt. Bei mir lief das.

Sub DoppelteZeilenLoeschen()
Dim letzteZeile As Long
Dim Zeile As Long
letzteZeile = Range("B" & Rows.Count).End(xlUp).Row

For Zeile = letzteZeile To 1 Step -1
    If Evaluate("SUMPRODUCT(((B1:B" & Zeile & "&J1:J" & Zeile & ")=(B" & Zeile & "&J" & Zeile & "))*1)>1") Then
        Rows(Zeile).EntireRow.Delete
    End If
Next
End Sub

lokke526

Beitragsersteller

31.05.2020, 18:02

Bestens, dank, es funktioniert wie es soll :)

Oubyi, UserMod Light

31.05.2020, 20:29

@lokke526

Gern geschehen 😊.

IchMalWiederXY

Von gutefrage auf Grund seines Wissens auf einem Fachgebiet ausgezeichneter Nutzer

Microsoft Excel

29.05.2020, 14:35

Ich würde mir die beiden Einzelinhalte merken und mit Worksheetsfunction.Match
prüfen, ob beide Inhalte erneut in der gleichen Zeile vorkommen.
Den Bereich für diesen Vergleich würde ich nur bis (Zeile-1) laufen lassen. (Aber auch bei der 'letzten' beginnen.
Aus meiner Sicht muss es eine While Schleife werden, da nicht zwingend bei jedem Lauf die Zeile verändert werden darf. Weil ja auch Dinge dreifach, mehrfach doppelt sein können.

m8fun

29.05.2020, 14:39

Ich muss dazu sagen, dass ich normalerweise nichts mit VB mache, aber soweit ich den Code verstehen kann, sollte diese Anpassung auch J prüfen. Ob die ganze Prüfung jetzt effektiv ist kann ich nicht beurteilen.

If WorksheetFunction.CountIf(Range("B1:B" & Zeile), Range("B" & Zeile)) > 1 AND WorksheetFunction.CountIf(Range("J1:J" & Zeile), Range("J" & Zeile)) Then

lokke526

Beitragsersteller

29.05.2020, 15:12

Das habe ich beriets schon ausprobiert, hat leider nicht funktioniert.

Ä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

VBA Wenn eine Zelle mehrerer Spalten leer dann msgbox?

Hallo zusammen,

ich habe vor in mehreren Spalten zu kontrollieren, ob sich eine leere Zelle befindet. Wenn ja soll eine Msgbox angezeigt werdne und der Sub soll beendet werden. Wenn nicht soll er fortfahren. Allerdings kommt es bei mir zu einer Fehlermeldung "Typen unverträglich". Wo hat sich der Fehler eingeschlichen? End If befindet sich weiter unten.

Sub SendMeetingRequest_2()

Dim Bereich As Range

Set Bereich = Range("F2:H41", "B2:B41") 'Zellbereich

With Application.WorksheetFunction

Dim objOL As Object 'As Outlook.Application

Dim objAppt As Object 'As Outlook.AppointmentItem

'Const olAppointmentItem = 1

Const olMeeting = 1

Dim ReminderTime As Long

Dim lfdnr As Integer

lfdnr = 2

'Überprüfung erstellen falls Aufgaben leer sind

'lfdnr = 4

If Bereich.Value = "" Then

MsgBox "Bitte fehlende Daten eintragen"

Call Leere_zellen_hervorheben

Exit Sub

Else

Danke für eure Hilfe!

...zum Beitrag

Kann mir jemand bei diesem Makro eine Schleife einbauen?

ich benötige dringend Hilfe bei diesem Makro!

ich habe dieses Makro von einem Mitglied von gf.

dieses Makro benötigt dringend eine Schleife

von Zeile 1 To 6000

also Zeile 1 ist SUMME(ZÄHLENWENN($A1:$F1;$L:$Q))

und Zeile 2 wäre dann $A2:$F2

und das Ganze dann bis Zeile 6000

Sub FormelAnpassen()

Dim spalte As Long

Dim zeile As Long

Dim bezugZeile As Long

zeile = 2

bezugZeile = 0

For spalte = 20 To 200

bezugZeile = bezugZeile + 1

Cells(zeile, spalte).FormulaArray = "=SUM(COUNTIF($A1:$F1,$L$" & bezugZeile & ":$Q$" & bezugZeile & "))"

End Sub

es wäre super wenn mir jemand helfen würde

danke im voraus

...zum Beitrag

VBA nur die ersten Unterordner anzeigen lassen?

Hallo,

wie muss ich diesen Code hier umschreiben damit NICHT die Unterordner der Unterordner angezeigt werden, sondern nur die der 'ersten Stufe'.

Also angenommen auf dem Laufwerk C:\ sind die Ordner

A, B, C, D, E

und diese Unterordner von C:\ enthalten jeweils auch Unterordner Namens
aa, bb, cc, dd, ee,

Dann schreibt der bisherige Code

A - aa
bb
cc
dd
ee
B - aa
bb

und so weiter.
Ich brauche aber nur die Ordner A, B, C, D, E und nicht deren Unterordner.

Public Sub OrdnerListen_Start()

Dim fso As Object
Dim strPfad As String

strPfad = "C:\"

With ActiveSheet

.UsedRange.ClearContents

Set fso = CreateObject("Scripting.FileSystemObject")

Call OrdnerListen(fso, strPfad, .Range("A1")) ' Pfad anpassen!

Set fso = Nothing

End With

End Sub

Private Sub OrdnerListen(fso As Object, Ordnerangabe As String, rng As Range, Optional Zeile As Long, Optional Spalte As Long)

On Error Resume Next

Dim o, uo

Set o = fso.GetFolder(Ordnerangabe)

rng.Offset(Zeile, Spalte).Value = o.Name
Zeile = Zeile + 1

For Each o In o.SubFolders

Call OrdnerListen(fso, o.Path, rng, Zeile, Spalte)

Set o = Nothing
Set uo = Nothing

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

Excel VBA Zellen in ein anderes Tabellenblatt Kopieren wenn Bedingung erfüllt?

Hallo,

ich habe ein problem und habe keine Ahnung von VBA.

Ich habe eine Tabelle in "A" steht der Name in "P" der Kurs und in "Y" ist die Bedingung "ja" oder "nein".

Das war das einzige das ich gefunden habe was auch funktionierte. Allerdings Kopiert es die komplette Zeile.

Sub BedingteKopieZeilen()

Dim Zeile As Long

Dim ZeileMax As Long

Dim n As Long

With Tabelle2

ZeileMax = .UsedRange.Rows.Count

n = 7

For Zeile = 3 To ZeileMax

If .Cells(Zeile, 25).Value = "Kurtaxe" Then

.Rows(Zeile).Copy Destination:=Tabelle10.Rows(n)

n = n + 1

End If

Next Zeile

End With

End Sub

Ich bedanke mich für eure Hilfe

Bernd

...zum Beitrag

VBA Ausgewählte Zeilen kopieren und in anderer Tabelle einfügen (mit Variablen)?

Hallo Zusammen,

Ich hab ein Problem. Ich würde gern durch das schreiben einer 1 hinter meiner Materialsammlung per Knopfdruck alle gewählten Zeilen in eine Zusammengestellte Tabelle einfügen.

Die Materialsammlung bei der ich auswähle ist in Tabelle zwei und wird dann per Knopfdruck abgefragt. Die markierten sollen dann in Tabelle 1 in eine Tabelle eingefügt werden.

Da ich aber mit Variablen Arbeite ist das schwieriger als gedacht

Hier mein code zum verdeutlichen

Private Sub CommandButton1_Click()

Dim strBereich As Range Dim x As Integer

For x = 3 To 60 If Worksheets(2).Cells(x, 10) = "1" Then

Worksheets(1).Range(Cells(x, 2), Cells(x, 9))=Worksheets(2).Range(Cells(x, 1), Cells(x, 8))

End If Next x

End Sub

funktioniert leider aber nicht.

Bitte im Hilfe

...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

vb.net Excel Makro funktioniert nicht wie gewünscht?

Sub MarkColumns()

Dim ws As Worksheet

Dim lastRow As Long, lastColumn As Long

Dim col As Long

Dim row As Long

Dim cell As Range

' Arbeitsblatt festlegen

Set ws = ThisWorkbook.Worksheets("Tabelle1") ' Ersetzen Sie "Tabelle1" durch den Namen Ihres Arbeitsblatts

' Letzte Zeile und letzte Spalte ermitteln

lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row

lastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

' Alle Spalten durchlaufen

For col = 1 To lastColumn

' Prüfen, ob ein Wert in irgendeiner Zeile der Spalte größer oder gleich 25 ist

For row = 1 To lastRow

Set cell = ws.Cells(row, col)

If cell.Value >= 25 Then

' Wenn ja, die gesamte Spalte markieren und zur nächsten Spalte wechseln

ws.Columns(col).Interior.Color = RGB(255, 0, 0)

Exit For ' Beenden Sie die Schleife, wenn ein Wert >= 25 gefunden wurde

End If

Next row

Next col

End Sub

Das Makro markiert jedeglich eine Spalte Rot, wenn ein Wert = 25 oder grösser 25 wenn diese Bedingung auf Zeile 1 zutrifft, es sollte jedoch die Spalte rot markieren egal in welcher Zeile der Wert gleich 25 oder grösser 25 ist.

Weis jemand wie ich das Makro anpassen muss damit es die gewünschte Funktionalität gewährleistet?

...zum Beitrag

VBA Programmierung - Automatischer Email versandt Probleme?

Hallo ich hoffe Ihr könnt mir helfen :/

Folgendes Problem: Wenn ich die Mail versende, öffnen sich für jede Zeile eine extra Email und leider auch nur jeweils ein Empfänger und einer in cc.

Was muss ich nun in der Programmierung hinzufügen, um nur eine Email geöffnet zu bekommen, mit mehreren Empfängern (Falls mehrere Kreuze gesetzt worden sind). Ich danke euch echt wenn Ihr mir helfen können :/

Ich habe mir die Bausteine aus dem Internet zusammengesetzt, bin daher kein Profi darin.

Programmtext:

Private Sub Send_Email()
   '-------------< Send_Email() >-------------
   Dim sTitle As String
   sTitle = "Test-HTML Email from Excel"
   '< HMTL holen >
   Dim sTemplate As String
   sTemplate = Sheets("ini_Vorlage").Shapes(1).TextFrame2.TextRange.Text
   '</ HMTL holen >
   '----< Send with Outlook >----
   Dim app_Outlook As Outlook.Application
   Set app_Outlook = New Outlook.Application
   '--< Email einstellen >--
   Dim objEmail As Outlook.MailItem
   Dim sEmail_Addresscc As String
   Dim sEmail_Address As String
   Dim iRow As Integer
   For iRow = 4 To 100
       If Cells(iRow, 21) = "x" Then
           '< get Email Address >
           'Column 2, B
           sEmail_Address = Cells(iRow, 19)
           sEmail_Addresscc = Cells(iRow, 20)
           '</ get Email Address >
           '< Fill Placeholders >
           Dim sHTML As String
           sHTML = Replace(sTemplate, "[@Name]", sEmail_Address)
           '</ Fill Placeholders >
           '--< Send Email >--
           Set objEmail = app_Outlook.CreateItem(olMailItem)
           objEmail.To = sEmail_Address
           objEmail.CC = sEmail_Addresscc
           objEmail.Subject = sTitle
           'objEmail.HTMLBody = sHTML 'use .HTMLBody for HTML
           objEmail.Body = sHTML      'and .body for pure Text
           objEmail.Display
           '--</ Send Email >--
       End If
   Next
   '< Abschluss >
   Set objEmail = Nothing
   Set app_Outlook = Nothing
   '</ Abschluss >
   MsgBox "Emails erstellt", vbInformation, "Fertig"
   '----</ Send with Outlook >----
   '-------------</ Send_Email() >-------------
End Sub

...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

Makro zum Zusammenfassen von Spalten

Hallo alle zusammen,

ich hab ein kleines Problem mit einem Makro, welches ich mir mit Hilfe diverser Quellen versucht habe auf meinen Fall zusammenzuschustern. Folgendermaßen kann man sich die Grundsituation vorstellen:

Ich habe in den Spalten D Und E ca 70 Zeilen mit Einträgen. Bis auf die Zellen 11 - 14 Ist die Spalte E leer. Also wollte ich ein Makro benutzen, welches die Spalte D wenn D und/oder E leer sind mit E zusammenfasst und sonst nicht.

Das soll dann auch für die Spalten F,G und H,I und immer soweiter klappen. Wer könnte mir Helfen und zeigen wo mein Fehler liegt denn bisher funktioniert das Makro nicht ganz so wie ich mir das vorgestellt habe.

Sub Formatierung()

Dim Zeile As Integer Dim Spalte As Integer

For Spalte = 4 To 256 Step 2
For Zeile = 1 To 100

If ((Not (IsEmpty(Cells(Spalte, Zeile)))) = True And IsEmpty(Cells(Spalte + 1, Zeile)) = True) Then
Range(Cells(Zeile, Spalte), Cells(Zeile, Spalte + 1)).Merge
End If

If IsEmpty(Cells(Spalte, Zeile)) = True And IsEmpty(Cells(Spalte + 1, Zeile)) = True Then
Range(Cells(Zeile, Spalte), Cells(Zeile, Spalte + 1)).Merge
End If

Next Zeile

Next Spalte

End Sub

So sieht das bisher aus. Für jede Hilfe vorab schonmal besten Dank

...zum Beitrag

VBA Objektvariable oder With Blockvariable nicht festgelegt?

Hallo habe folgenden Code:

Bekomme beim debuggen nach der Zeile "Objektvariable oder With-Blockvariable nicht festgelegt" Ich sehe mein Fehler leider nicht, hat jemand eine Ahnung?

Dim wbSAP As Workbook
Dim wbStamm As Workbook
Dim sapSheet As Worksheet
Dim stammSheet As Worksheet
Dim sapRange As Range
Dim stammRange As Range
Dim curSapCell As Range
Dim foundStammCell As Range
Dim nextStammRowNr As Integer
Set wbSAP = Workbooks.Open(ThisWorkbook.Path & "\SAP-Abfrage_GEN-User_SUIM.xls") 
Set wbStamm = ThisWorkbook


Set sapSheet = wbSAP.Sheets("SAP-Abfrage_GEN-User_SUIM") 
Set stammSheet = wbStamm.Sheets("Tabelle1")


Set sapRange = sapSheet.Range("B29:B105") 
Set stammRange = stammSheet.Range("F2:F81")


For Each curSapCell In sapRange  
   
foundStammCell = stammRange.Find(curSapCell.Value, LookAt:=xlWhole)     
If Not foundStammCell = curSapCell.Value Then  
       
stammSheet.Range("M" & nextStammRowNr) = sapSheet.Range("M" & curSapCell.Row).Value        
 nextStammRowNr = nextStammRowNr + 1     
Else        
stammSheet.Range("M" & foundStammCell.Row) = sapSheet.Range("M" & curSapCell.Row).Value     
End If
Next curSapCell

...zum Beitrag

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

...zum Beitrag

Was möchtest Du wissen?

Deine Frage stellen