Zellinhalte vergleichen!
21.09.2007 14:17:00
Timo
Mit folgendem CODE den ich mir über google und mein bescheidenes VBA wissen erstellt habe lese ich mir alle
.txt - Dateien eines Verzeichnisses in die Spalte A ein.
Nun würde ich diese gerne mit den Einträgen in den Spalten B bis M vergleichen und falls es eine Übereinstimmung gibt, den Wert aus der ersten Zeile der gefundenen Übereinstimmung z.B B1 in die Textdatei von Spalte A mit "'#Edition:" & z.B eben B1 eintragen lassen!
Und diesen Vorgang wiederholen bis alle Einträge von Spalte A mit den Einträgen von Spalte B bis M verglichen wurden.
Hier mein CODE zum einlesen:
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare
Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private z!
'Ruft das Dialogfeld zur Ordnerauswahl auf
Function GetDirectory(Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
With bInfo
.pidlRoot = 0&
.lpszTitle = Msg
.ulFlags = &H1
End With
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub Dateisuche(Laufwerk, Dateien)
Dim tmp, Wdhlg, Dateiname As String
On Error Resume Next
If Right(Laufwerk, 1) "\" Then Laufwerk = Laufwerk + "\"
tmp = Dir(Laufwerk & Dateien)
Do While Len(tmp)
Dateiname = Laufwerk & tmp
Application.StatusBar = Dateiname
Cells(z, 1).Select
Cells(z, 1) = tmp 'nur Dateiname
z = z + 1
tmp = Dir()
Loop
tmp = Dir(Laufwerk, vbDirectory)
Do While Len(tmp)
If (tmp ".") And (tmp "..") Then
If (GetAttr(Laufwerk & tmp) And vbDirectory) = vbDirectory Then
Dateisuche Laufwerk & tmp, Dateien
z = z - 1
Wdhlg = Dir(Laufwerk, vbDirectory)
z = z + 1
Do While Wdhlg tmp
Wdhlg = Dir()
Loop
End If
End If
tmp = Dir()
Loop
On Error GoTo 0
Application.StatusBar = False
End Sub
'Aufruf mit dem folgenden Makro
Sub Suchen()
Dim Laufwerk$, Dateien$
'Ersze Zeile, in der eine Eintragung erfolgt
z = 2
'Alte Eintragungen löschen
[a1:a5000] = ""
'Den Variablen Laufwerk und Dateien kann
'auch ein direkter Wert zugewiesen werden.
'Ersatz: ... = "C:\Eigene Dateien"
Laufwerk = GetDirectory("Hir das verzeichniss eintragen wo gesucht werden soll")
If Laufwerk = "" Then Exit Sub
Dateien = "*.txt"
'Dateien = InputBox("Nach welchen Dateien soll in" & _
' Chr(10) & " " & Laufwerk & Chr(10) & _
' "gesucht werden (z. B. *.xls)?", _
' "Dateityp", "*.*")
'If Dateien = "" Then Exit Sub
Dateisuche Laufwerk, Dateien
Call txt_wegmachen
Call Sortierung
End Sub
Sub txt_wegmachen()
With Sheets(1)
Cells.Replace What:=".txt", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End With
End Sub
Sub Sortierung()
With Sheets(1)
Columns("A:A").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
End Sub
Danke für Eure Hilfe!
Gruß Timo