AW: Suche nach Doppelten Werten und Ausgabe in MsgBox
07.08.2019 16:39:55
Carlos
Ich habe den kompletten Code jetzt mal eingefügt.
Es wäre super wenn es sich jemand mal ansehen könnte ob er den Fehler findet.
Der Befehl, die doppelten Werte zu suchen ist ebenfalls drinnen, aber ich weiß nicht, wieso er es nicht richtig ausführt.
VG
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo Fehler
Workbooks.Open "P:\CE\Sales Operation\02.SD CE - Cen\01.Sales & BOC\_Exclusion_\BA Team\Ba _
Report Vormittags\BA Report.xlsx"
Worksheets.Add
ActiveCell.Value = "Antworten"
ActiveCell.Offset(1, 0).Select
Dim cDir As String
Dim sPath As String
Dim Firstfile As Object
sPath = "P:\CE\BA\BA Rückmeldungen\"
cDir = Dir(sPath & "*.xlsx")
Do While cDir ""
Workbooks.Open (sPath & cDir)
Set Firstfile = ActiveWorkbook
cDir = Dir
With ActiveSheet.AutoFilter.Range.Offset(1)
.Resize(ActiveSheet.AutoFilter.Range.Rows.Count - 1).EntireRow.Copy
End With
Windows("BA Report.xlsx").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:= _
False
Application.CutCopyMode = False
ActiveSheet.Range("a1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Firstfile.Close
Loop
'Sheets("Tabelle1").Cells(1, 18).Value = "Doppelcheck"
'Sheets("Tabelle1").Cells(2, 17).Select
'Selection.End(xlDown).Select
'ActiveCell.Offset(, 1).Select
Dim intr1 As Integer, intr2 As Integer, Suchspalte As Integer
Suchspalte = 1
For intr1 = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For intr2 = intr1 + 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(intr1, Suchspalte) = Cells(intr2, Suchspalte) Then
MsgBox Cells(intr1, Suchspalte).Value & " ist doppelt vorhanden (Zeile" & intr1 & " _
und " & intr2 & ")"
End If
Next intr2
Next intr1
Worksheets("BA Report Orderdesk").Activate
ActiveSheet.Range("Ag1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(, 1).Select
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP(C[-32],Tabelle1!C[-33]:C[-17],17,FALSE),0)"
Selection.Copy
ActiveSheet.Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("AH1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Font.Bold = True
ActiveSheet.Range("AH2").Select
Dim y As String
y = 0
y = y + 1
Do
If ActiveCell "0" Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(, -1).Select
Selection.Copy
ActiveCell.Offset(, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell)
Worksheets("Tabelle1").Delete
ActiveWorkbook.SaveAs Filename:="P:\CE\Sales Operation\02.SD CE - Cen\01.Sales & BOC\ _
_Exclusion_\BA Team\BA Report Nachmittags\Ba Report.xlsx"
Application.DisplayAlerts = True
MsgBox "Antworten wurden übernommen und der BA Report gespeichert.", vbInformation
Exit Sub
Fehler:
MsgBox "Bitte alle Dateien auf Fehler prüfen, Makro wird beendet", vbCritical
End Sub