Datenabgleich über zwei Spalten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

' ********************************************************************** ' Modul: basMain Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub GetData() Dim objWB As Workbook, objSH As Worksheet Dim rngAll As Range, rng As Range Dim objFSO As Object, objFile As Object, objFolder As Object Dim vntRet As Variant Dim lngCalc As Long, lngCount As Long, lngC As Long On Error GoTo ErrExit With Application .ScreenUpdating = False .EnableEvents = False lngCalc = .Calculation .Calculation = xlCalculationManual .DisplayAlerts = False End With Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(ThisWorkbook.Path) Set objSH = ThisWorkbook.Sheets("Tabelle1") lngCount = objFolder.Files.Count For Each objFile In objFolder.Files lngC = lngC + 1 Application.StatusBar = "Bearbeite Datei " & lngC & " von " & lngCount & " - Bitte Warten!" If LCase(objFile.Name) Like "*.xls*" And Not LCase(objFile.Name) Like "*~$*" Then If LCase(objFile.Path) <> LCase(ThisWorkbook.FullName) Then Set rngAll = Nothing Set objWB = Workbooks.Open(objFile.Path, False) If SheetExist("Tabelle1", objWB) Then On Error Resume Next Set rngAll = objWB.Sheets("Tabelle1").Columns(1).SpecialCells(xlCellTypeConstants) On Error GoTo 0 If Not rngAll Is Nothing Then For Each rng In rngAll vntRet = Application.Match(rng, objSH.Columns(1), 0) If IsNumeric(vntRet) Then If rng.Offset(0, 1) = objSH.Cells(vntRet, 2) Then rng.Offset(0, 2) = objSH.Cells(vntRet, 3) End If End If Next End If End If objWB.Close True End If End If Next ErrExit: With Err If .Number <> 0 Then MsgBox "Fehler in Prozedur:" & vbTab & "'GetData'" & vbLf & String(60, "_") & _ vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _ "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _ .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _ "VBA - Fehler in Modul - Modul2" .Clear End If End With On Error GoTo 0 With Application .ScreenUpdating = True .EnableEvents = True .Calculation = lngCalc .DisplayAlerts = True .Application.StatusBar = False End With Set rngAll = Nothing Set rng = Nothing Set objSH = Nothing Set objWB = Nothing Set objFolder = Nothing Set objFile = Nothing Set objFSO = Nothing End Sub Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean Dim wks As Worksheet On Error GoTo ERRORHANDLER If Wb Is Nothing Then Set Wb = ThisWorkbook For Each wks In Wb.Worksheets If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function Next ERRORHANDLER: SheetExist = False End Function

Hallo Sepp,
danke vielmals... das ist ja der absolute Hammer?!? Wie schnell hast du denn den Code aus dem Ärmel gezaubert? Sehr geil, deine Hilfe... wirklich, ganz grossen Dank! :)
Ich habe versucht deinen Code nachzuvollziehen und habe diesen einmal in ein Modul eingebaut und laufen lassen. Hat funktioniert, aber leider nicht so wie ich wollte und aber auch nur deswegen nicht, weil ich der Einfachheit halber nicht die ganze Wahrheit geschrieben hatte:
In der Datei Y entspricht die zu matchende Spalte A in Wirklichkeit der Spalte S und Spalte B der Spalte T und Spalte C der Spalte AA.
DateiX.SpalteA = DateiY.Spalte S
DateiX.SpalteB = DateiY.Spalte T
DateiX.SpalteC = DateiY.Spalte AA
Habe es nicht verkomplizieren wollen und darum nicht erwähnt. Ich dachte, ich könnte es relativ easy abändern... ich kann es natürlich nicht! Eigentlich müsste das aber doch "relativ" easy durch die Offset-Zahl anzupassen sein? Jedoch habe ich eines auch noch nicht verstanden: die Prüfung, ob der Zellinhalt ein numerischer Wert ist? Wozu ist das gut? Zumal die Zellwerte alle nur einen String-Wert enthalten? Kannst du mir dazu bitte eine kleine Info geben? Alle Werte in den Spalten A,B,C bzw. S, T und AA enthalten String-Werte (alphanumerisch)...
Hier ist der besprochene Abschnitt (der Match findet ja hier statt)
If IsNumeric(vntRet) Then
If rng.Offset(0, 1) = objSH.Cells(vntRet, 2) Then
rng.Offset(0, 2) = objSH.Cells(vntRet, 3)
End If
End If
Vielen Dank und viele Grüsse,
Sinan

Hallo Sinan,
hier der angepasste Code mit ein paar Kommentaren.

' **********************************************************************
' Modul: basMain  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub GetData()
  Dim objWB As Workbook, objSH As Worksheet
  Dim rngAll As Range, rng As Range
  Dim objFSO As Object, objFile As Object, objFolder As Object
  Dim vntRet As Variant
  Dim lngCalc As Long, lngCount As Long, lngC As Long
  
  'Fehlerbehandlung
  On Error GoTo ErrExit
  
  'EXCEL 'ruhig' stellen
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  Set objFSO = CreateObject("Scripting.FileSystemObject") 'FileSystemObject erstellen
  Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)     'Ordner-Object erstellen
  Set objSH = ThisWorkbook.Sheets("Tabelle1")             'Tabelle1 in dieser Mappe
  
  lngCount = objFolder.Files.Count
  
  For Each objFile In objFolder.Files 'Dateien im Ordner durchlaufen
    lngC = lngC + 1
    Application.StatusBar = "Bearbeite Datei " & lngC & " von " & lngCount & " - Bitte Warten!"
    If LCase(objFile.Name) Like "*.xls*" And Not LCase(objFile.Name) Like "*~$*" Then 'Dateinamen (Erweiterung) prüfen
      If LCase(objFile.Path) <> LCase(ThisWorkbook.FullName) Then 'Wenn Datei ist NICHT diese Datei
        Set rngAll = Nothing
        Set objWB = Workbooks.Open(objFile.Path, False) 'Datei öffnen
        If SheetExist("Tabelle1", objWB) Then 'Wenn 'Tabelle1' in Datei enthalten
          On Error Resume Next
          Set rngAll = objWB.Sheets("Tabelle1").Columns(1).SpecialCells(xlCellTypeConstants)  'betroffene Zellen ermitteln
          On Error GoTo 0
          If Not rngAll Is Nothing Then 'Zellen durchlaufen
            For Each rng In rngAll
              'Match = Vergleich(Wert aus Zelle, Spalte S in Datei)
              vntRet = Application.Match(rng, objSH.Columns(19), 0) '.Columns(19) = Spalte S
              If IsNumeric(vntRet) Then 'wenn der Vergleich eine Zahl = Zeile zurückliefert
                If rng.Offset(0, 1) = objSH.Cells(vntRet, 20) Then  '20 = Spalt T
                  rng.Offset(0, 2) = objSH.Cells(vntRet, 27)        '27 = Spalte AA
                End If
              End If
            Next
          End If
        End If
        objWB.Close True  'datei schließen
      End If
    End If
  Next
  
  'Fehlerbehandlung
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'GetData'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Modul - Modul2"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
    .Application.StatusBar = False
  End With
  
  Set rngAll = Nothing
  Set rng = Nothing
  Set objSH = Nothing
  Set objWB = Nothing
  Set objFolder = Nothing
  Set objFile = Nothing
  Set objFSO = Nothing
End Sub


Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function

PS: Mit 'IsNumeric()' wird nicht geprüft ob der Zellinhalt eine Zahl ist, sondern ob der Vergleich eine Zahl (=Zeilennummer) liefert und damit einen Treffer ergeben hat.

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Datenabgleich über zwei Spalten

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread