Zahlen vergleichen

Private Sub CommandButton1_Click() Dim WS1 As Worksheet, WS2 As Worksheet Dim iZeile As Long, LetzteZeile As Long Set WS1 = ThisWorkbook.ActiveSheet 'entspricht daten1.xls Set WS2 = Workbooks("Mappe2.xls").Worksheets("Tabelle1") 'entspricht daten2.xls LetzteZeile = WS1.Range("A65536").End(xlUp).Row With Application .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With For iZeile = LetzteZeile To 1 Step -1 If WorksheetFunction.CountIf(WS2.Columns("A:A"), WS1.Cells(iZeile, 1)) > 0 Then Rows(iZeile).EntireRow.Delete Next iZeile With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True .EnableEvents = True End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub suchen() If MsgBox("daten übertragen ? ", vbInformation + vbYesNo) = 7 Then Exit Sub Dim LoLetzte As Long With Worksheets("Arbs") If Application.WorksheetFunction.CountIf(.Range("A6:A" & .Range("B65536").End(xlUp).Row), Worksheets("Reps").Range("A6")) > 0 Then MsgBox "Eintrag bereits vorhanden." Exit Sub Mein Problem noch einmal: möchte die Daten aus der Spalte "C" (stehen Nr. drin) ab c5 (Tabelle1) mit der (Tabell3)Spalte "C" ab c5 vergleichen. Wenn der Wert aus der Tabelle 1 NICHT in der Tabelle 3 vorhanden ist, soll die Zeile c bis H der "Tabelle 1" gelöscht werden. Übrings Ende der Spalte C kann mal 100 mal 500 Zeilen sein. mfg walterB End If LoLetzte = wa.Range("b65536").End(xlUp).Row + 1 .Cells(LoLetzte, 1) = Worksheets("Rebs").Range("h11") .Cells(LoLetzte, 2) = Worksheets("Rebs").Range("h10") Sheets("Arbs").Select If MsgBox("Daten archiviert!", vbInformation + vbYesNo, "OFFICECONTROL") = 6 Then Sheets("tab1").Select End If End With End Sub

Private Sub CommandButton1_Click() Dim WS1 As Worksheet, WS2 As Worksheet, BereichTab3 As Range Dim iZeile As Long, LetzteZeile As Long Set WS1 = ThisWorkbook.ActiveSheet 'Tabelle mit dem Button1 Set WS2 = ThisWorkbook.Worksheets("Tabelle3") Set BereichTab3 = WS2.Range(WS2.Cells(5, "C"), WS2.Cells(WS2.Rows.Count, "C").End(xlUp)) With Application .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With With WS1 LetzteZeile = .Cells(.Rows.Count, "C").End(xlUp).Row 'Letzte Zeile in Spalte C Tabelle 1 For iZeile = LetzteZeile To 5 Step -1 If Application.WorksheetFunction.CountIf(BereichTab3, .Cells(iZeile, "C").Value) = 0 Then .Range(.Cells(iZeile, "C"), .Cells(iZeile, "H")).Delete Shift:=xlShiftUp End If Next iZeile End With With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True .EnableEvents = True End With End Sub

Private Sub CommandButton1_Click() Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet, BereichTab4 As Range, BereichTab3 As Range Dim iZeile As Long, LetzteZeile As Long Set WS1 = ThisWorkbook.ActiveSheet 'Tabelle mit dem Button1 Set WS2 = ThisWorkbook.Worksheets("Tabelle3") Set WS3 = ThisWorkbook.Worksheets("Tabelle4") Set BereichTab3 = WS2.Range(WS2.Cells(5, "C"), WS2.Cells(WS2.Rows.Count, "C").End(xlUp)) Set BereichTab4 = WS3.Range(WS3.Cells(5, "C"), WS3.Cells(WS3.Rows.Count, "C").End(xlUp)) With Application .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With With WS1 LetzteZeile = .Cells(.Rows.Count, "C").End(xlUp).Row 'Letzte Zeile in Spalte C Tabelle 1 For iZeile = LetzteZeile To 5 Step -1 If Application.WorksheetFunction.CountIf(BereichTab3, .Cells(iZeile, "C").Value) + _ Application.WorksheetFunction.CountIf(BereichTab4, .Cells(iZeile, "C").Value) = 0 Then .Range(.Cells(iZeile, "C"), .Cells(iZeile, "H")).Delete Shift:=xlShiftUp End If Next iZeile End With With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True .EnableEvents = True End With End Sub

Private Sub CommandButton1_Click() Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet, BereichTab4 As Range, BereichTab3 As Range Dim iZeile As Long, LetzteZeile As Long 'Variablen für Tabellen die entsprechenden Tabellen zuweisen Set WS1 = ThisWorkbook.ActiveSheet 'Tabelle mit dem Button1 Set WS2 = ThisWorkbook.Worksheets("Tabelle3") Set WS3 = ThisWorkbook.Worksheets("Tabelle4") 'Bereich festlegen mit den Werten in Tabelle 3, die mit den Werten in Tabelle 1 verglichen werden sollen Set BereichTab3 = WS2.Range(WS2.Cells(5, "C"), WS2.Cells(WS2.Rows.Count, "C").End(xlUp)) 'Bereich festlegen mit den Werten in Tabelle 4, die mit den Werten in Tabelle 1 verglichen werden sollen Set BereichTab4 = WS3.Range(WS3.Cells(5, "C"), WS3.Cells(WS3.Rows.Count, "C").End(xlUp)) 'Automatische Berechnung und Ereignismakros deaktivieren, insbesondere dann erforderlich, wenn _ die Tabellen umfangreiche Berechnungen automatisch auf Zellwertänderungen _ reagierende Makros enthalten. With Application .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With With WS1 'Ermitteln der letzten Zeile in Spalte C, die noch Werte emthält LetzteZeile = .Cells(.Rows.Count, "C").End(xlUp).Row 'Zellen in Tabelle 1 Spalte C von der Letzten bis zue 5. Zeile mit den Werten in den _ anderen Tabellen vergleichen For iZeile = LetzteZeile To 5 Step -1 ' In der If-Bedingung wird gezählt, wie oft der Begriff in der Zelle in Tabelle 1 in den _ beiden Bereichen in Tabelle 3 und 4 vorkommt. Bei 0 wird in Tabelle 1 der Zellbereich gelöscht If Application.WorksheetFunction.CountIf(BereichTab3, .Cells(iZeile, "C").Value) + _ Application.WorksheetFunction.CountIf(BereichTab4, .Cells(iZeile, "C").Value) = 0 Then .Range(.Cells(iZeile, "C"), .Cells(iZeile, "H")).Delete Shift:=xlShiftUp End If Next iZeile End With 'Berechnung wieder auf Automatisch stellen und die Ereignismakros wieder aktivieren With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True .EnableEvents = True End With End Sub

Hallo,
habe jetzt mal rumgetestet, leider komme ich nicht zu meinem Ergenis.
Das folgenden Makro funktioniert, es wird in der Sheet erstellt und die Sheet ist dann
eine xls Datei. Meine Ursprungsdatei wo diese Sheet drin war /ist heißt:
"Werkstatt.xls" , dies Datei ist noch aktiviert und ich könnte jetzt von dieser aus
ein Makro starten und in der Neu erstellten Mappe.xls diese reinkopieren.
Irgenwie ans Ende setzen ?
Nochmals Entschuldigung, wenn ich mich jetzt erst gemeldet habe, bin etwas im Streß, muß
und möchte das aber jetzt zu Ende bringen.
Hier mein Makro auch mit MIthilfe Forum erhalten und teilweise ergänzt, wie gesagt es funktioniert:
'------------ Datei erstellen -----------------------------------------


Private Sub CommandButton1_Click()
Dim strPath As String
Dim strPathCe As String
Dim objSh As Worksheet
Dim objWb As Workbook
Dim blnExist As Boolean, blnClose As Boolean
Dim OrdNam1 As String
Dim OrdNam2 As String
Dim OrdNam3 As String
Dim OrdNam4 As String
Dim wwww
Dim aktWb As Workbook
Set aktWb = ActiveWorkbook
strPath = "C:\Werkstatt\Lager"
Set objSh = ActiveSheet
'------- akt. Sheet Name in Zellen setzen ----------
Dim vn As String
vn = ActiveSheet.name
ActiveSheet.Cells(1, 8).Value = vn
'----------- akt. Sheet Name mit Datum -------------
Dim dn As String
dn = ActiveSheet.name & "   Teile Nr. vom" & Cells(4, 1) & ".xls"
ActiveSheet.Cells(2, 8).Value = dn
strPathCe = "C:\Werkstatt\Lager\" & ActiveSheet.Cells(1, 8).Value
OrdNam1 = "C:\Werkstatt\"
OrdNam3 = ActiveSheet.Cells(1, 8).Value                 'Lager Name allein
OrdNam4 = ActiveSheet.Cells(2, 8).Value                 'Teile-Abt allein
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
If Dir(strPathCe, vbDirectory) <> "" Then
Else
MsgBox "Verzeichnis Lager ist NICHT  vorhanden"
MkDir strPathCe
End If
If Dir(strPathCe & "\" & OrdNam4, 16) <> "" Then
blnExist = True
If MsgBox("Die Datei: " & vbLf & vbLf & vbTab & Chr(34) & OrdNam4 & Chr(34) _
& "          " & vbLf & vbLf & "Im Verzeichnis: " & vbLf & vbLf & _
vbTab & Chr(34) & strPathCe & Chr(34) & vbLf & _
vbLf & vbLf & "ist bereits vorhanden!" & vbLf & vbLf & _
"Soll die Datei ersetzt werden ?", 36, "Frage") = 7 Then
blnClose = True
GoTo ErrExit
End If
End If
For Each objWb In Workbooks
If MsgBox("Die Datei: " & vbLf & vbLf & vbTab & Chr(34) & OrdNam4 & Chr(34) & _
Space(15) & vbLf & vbLf & "ist zur Zeit geöffnet!" & vbLf & vbLf & _
"Um fortzufahren, muss die Datei geschlossen werden!", 33, "Frage") = 2 Then
blnClose = True
GoTo ErrExit
End If
ActiveWorkbook.Save                 'neu gesetzt
objWb.Close False               'alte Mappe
Exit For
End If
Next
objSh.Copy
With ActiveWorkbook
Application.DisplayAlerts = False                 ' Sicherheitsabfrage unterdrücken
.SaveAs strPathCe & "\" & OrdNam4
End With
ErrExit:
If Err.Number = 0 Then
If blnClose Then
MsgBox "Der Vorgang wurde Abgebrochen!  ", 64, "Hinweis"
Exit Sub
Else
MsgBox "Die Datei: " & vbLf & vbLf & vbTab & Chr(34) & OrdNam4 & Chr(34) & _
"                 " & vbLf & vbLf & _
"Im Verzeichnis: " & vbLf & vbLf & vbTab & Chr(34) & strPathCe & Chr(34) & _
vbLf & vbLf & vbTab & Space(15) & _
vbLf & vbLf & "wurde erfolgreich " & IIf(blnExist, "ersetzt", "erstellt") & "!", 64, "Hinweis"
End If
Else
'MsgBox "Beim speichern der Datei" & vbLf & vbLf & vbTab & strPath & objSh.Name & ".xls" & Space(15) & _
'    vbLf & vbLf & "trat folgender Fehler auf" & vbLf & vbLf & Err.Description & Space(15), 48, "Fehler"
Err.Clear
End If
Set objSh = Nothing
'- hier die erstellte Datei rein -----
Dim aaw
Set aaw = ActiveWorkbook
aktWb.Activate
With ActiveWorkbook
If .name Like "Werkstatt.xls" Then
'MsgBox "Walter"
Else
With ActiveWorkbook
If Not .name Like "Center*" Then
MsgBox "Die Datei: " & vbLf & vbLf & .name & vbLf & vbLf & _
"wird jetzt mit dem Orginal-Namen gespeichert !    "
strPathCe = aktWb.Path & "\" & aktWb.name
aktWb.Close
Kill strPathCe
Else
MsgBox "Die Datei: " & vbLf & vbLf & .name & vbLf & vbLf & _
"hat einen Lager-Namen, wird nicht gelöscht !   "
End If
End With
End If
End With
aaw.Activate
End Sub

mfg Walter

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zahlen vergleichen

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread