zwei Spalten vergleichen
René
ich habe einen Code mit dem ich in zwei Spalten eines Tabellenblattes Hyperlinks aus zwei verschiedenen Ordnern auflisten lasse.
Nach dem Auflisten der Dateien mit diesem Makro möchte ich erreichen das die zwei Spalten verglichen werden und in Spalte A nur noch die Dateien stehen die keine zugeordnete Datei in Spalte E haben
In Spalte A steht zum Beispiel die Datei (als Hyperlink)
BA aus QS_PZ_A6_2011_194_KW20_Magnetventil f_ Kühlmittelkreislauf Standheizung_19_05_2011.xlsm
und in Spalte E die Datei (als Hyperlink)
AW BA aus QS_PZ_A6_2011_194_KW20_Magnetventil f_ Kühlmittelkreislauf Standheizung_19_05_2011.msg
In Spalte A stehen Datein mit der Endung .xlsm und in Spalte E mit der Endung .msg
Als Zuordnungskriterium für das Vergleichen soll jeweils die Zahl nach 2011 genommen werden, hier in dem Fall 194
Könnt ihr mir bitte einen Tipp geben?
Sub Schaltfläche299_Klicken()
ActiveSheet.Unprotect
Dim strDatei As String, strVerzeichnis As String, lngZ As Long
With ActiveSheet
'1 -------------------------------------------------------------------------------
strVerzeichnis = "Y:\Beanstandungen_2011\"
If Dir(strVerzeichnis, vbDirectory) = "" Then
MsgBox strVerzeichnis & " wurde nicht gefunden!" & Space(10), 64, "weise hin..."
Exit Sub
End If
.Columns(1).ClearContents
strDatei = Dir(strVerzeichnis & "*" & Cells(3, 3) & "*.xlsm", vbNormal)
If Dir(strVerzeichnis & "*" & Cells(3, 3) & "*.xlsm", vbNormal) = "" Then
MsgBox ("Für diese Auswahl liegen keine erfassten Beanstandungen vor!")
End If
Do While strDatei ""
lngZ = lngZ + 2
.Hyperlinks.Add Anchor:=.Cells(lngZ, 1), _
Address:=strVerzeichnis & strDatei, SubAddress:="", _
TextToDisplay:=strDatei
strDatei = Dir
Loop
lngZ = 0
'2 -------------------------------------------------------------------------------
strVerzeichnis = "Y:\Rückmeldungen\"
If Dir(strVerzeichnis, vbDirectory) = "" Then
MsgBox strVerzeichnis & " wurde nicht gefunden!" & Space(10), 64, "weise hin..."
Exit Sub
End If
.Columns(5).ClearContents
strDatei = Dir(strVerzeichnis & "*" & Cells(8, 3) & "*.msg", vbNormal)
If Dir(strVerzeichnis & "*" & Cells(8, 3) & "*.msg", vbNormal) = "" Then
MsgBox ("Für diese Beanstandung liegen keine Rückmeldungen vor!")
End If
Do While strDatei ""
lngZ = lngZ + 2
.Hyperlinks.Add Anchor:=.Cells(lngZ, 5), _
Address:=strVerzeichnis & strDatei, SubAddress:="", _
TextToDisplay:=strDatei
strDatei = Dir
Loop
Range("A1").Select
Dim z As Long
Dim ws As Worksheet
Set ws = Worksheets("Tabelle1")
anzA = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim spalte As Long
For spalte = 15 To 242 Step 2
anzB = ws.Cells(Rows.Count, spalte).End(xlUp).Row
If ws.Cells(Rows.Count, spalte + 1).End(xlUp).Row = 1 Then
ze = ws.Cells(Rows.Count, spalte + 1).End(xlUp).Row + 1
End If
For z = 2 To anzB
suchzahl = ws.Cells(z, spalte)
With ws.Range("L2:A" & anzA)
Set c = .Find(suchzahl, LookIn:=xlValues, LookAt:=xlWhole)
If c Is Nothing Then
ws.Cells(ze, spalte + 1) = suchzahl
ws.Cells(z, spalte) = ""
ze = ws.Cells(Rows.Count, spalte + 1).End(xlUp).Row + 1
End If
End With
Next z
anzB = ws.Cells(Rows.Count, spalte).End(xlUp).Row
ws.Range(Cells(2, spalte), Cells(anzB, spalte)).Copy ws.Range("IV2")
ws.Range(Cells(2, spalte), Cells(anzB, spalte)).ClearContents
Dim y As Long
Dim suche As String
For y = 2 To anzB
If Cells(y, 256).Value "" Then
suche = Cells(y, 256).Value
With ws.Range("L2:A" & anzA)
Set x = .Find(what:=suche, LookIn:=xlValues, LookAt:=xlWhole)
If Not x Is Nothing Then
Dim reihe As Long
reihe = x.Row
Cells(reihe, spalte).Value = suche
ws.Cells(y, 256) = ""
End If
End With
End If
Next y
Next spalte
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
End Sub