Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1560to1564
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Zellen vergleichen, wenn gleich dann kopieren

Zellen vergleichen, wenn gleich dann kopieren
28.05.2017 18:34:54
Mooslechner
Hallo,
wieder mal sitz ich und versuche eine Lösung mit VBA zu finden
Tab = Abkürzung für Tabellenblatt
Problem: (finden gleicher Zellinhalts in beiden Tab, kopieren aus Tab Bibliothek nach Tab Station 000.
In der Excelmappe befinden sich 2 Tabellenblätter (Bibliothek und Station 000)
Möchte:
Tabellenblatt Station 000: befinden sich in der gleichen Zeile Spalte B Nummer und Spalte D Name.
Nehme Inhalt Zelle B2 und D2 aus Tab Station 000 und duchlaufe das Tab Bibliothek (selbe Spalten bis nach unten)
Bei Treffer kopiere von der gefundenen Zeile Inhalt der Zelle E bis K in Tab Station 000
Dann nächste Zeile in Tab Station 000 Zelle B3 und D3 und suchen in Tab Bibliothek, bis alle Zeilen in Tab Station 000 durch sind.
Normal sind es ca. 200 Zeilen die ich regelmäßig mit der Bibliothek vergleiche.
Ich weiß es geht auch mit S-Verweis, doch bin ich von VBA fasziniert.
Lieber Excelexperte, vielen Dank für die Mühe. Meine Theorie:
Sub_vergleichen()
Dim LoLetzteB as Integer, LoLetzteSt as Integer
Dim I as Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("Bibliothek").Select
'ermittelt die letzte Zeile
loLetzteB = .Cells(.Rows.Count, 2).End(xlUp).Row
Sheets("Station 000").Select
loLetzteSt = .Cells(.Rows.Count, 2).End(xlUp).Row
If Worksheets("Station 000").Cells(I, B) & .Cells(I, D)= Worksheets("Bibliothek").Cells(I, B) & .Cells(I, D) Then
'kopiere bei Treffer Inhalt nach Zelle E bis K aus Bibliothek und füge in Tab Station 000 ein.
Next I
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zellen vergleichen, wenn gleich dann kopieren
28.05.2017 18:58:12
Sepp
Hallo Mooslechner,
ungetestet.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub vergleichen()
Dim varStation As Variant, varRet As Variant
Dim lngI As Long, lngN As Long

On Error GoTo ErrorHandler

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlManual
End With

With Sheets("Station 000")
  varStation = .Range("B2:C" & Application.Max(2, .Cells(.Rows.Count, 2).End(xlUp).Row))
  For lngI = 1 To UBound(varStation, 1)
    varRet = Application.Match(varStation(lngI, 1), Sheets("Bibliothek").Columns(2), 0)
    If IsNumeric(varRet) Then
      If varStation(lngI, 2) = Sheets("Bibliothek").Cells(varRet, 3) Then
        .Range(.Cells(lngI + 1, 3), .Cells(lngI + 1, 10)).Copy Sheets("Bibliothek").Cells(varRet, 3)
      End If
    End If
  Next
End With

ErrorHandler:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'vergleichen'" & vbLf & String(25, Chr(151)) & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf & vbLf & String(25, Chr(151)), 81968, _
      "VBA - Fehler in Prozedur - vergleichen", .HelpFile, .HelpContext
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = xlAutomatic
End With

End Sub

Gruß Sepp

Anzeige
Fehler!
28.05.2017 19:01:49
Sepp
Hallo nochmal,
diese Zeile muss so lauten!
.Range(.Cells(lngI + 1, 4), .Cells(lngI + 1, 11)).Copy Sheets("Bibliothek").Cells(varRet, 4)

Gruß Sepp

AW: Zellen vergleichen, wenn gleich dann kopieren
30.05.2017 21:49:09
Mooslechner
Hallo Sepp,
vielen Dank schon mal, wird am Wochenende getestet.
vg M.
Anzeige
AW: Zellen vergleichen, wenn gleich dann kopieren
05.06.2017 11:39:19
Mooslechner
Hallo Sepp,
jetzt hatte ich endlich Zeit.
Code hat Fehler:
Meldung:
Fehler in Prozedur
"vergleichen"
Fehlernummer 13
Beschreibung: Typen unverträglich
Vielen Dank für Deine Mühe
Code:
Option Explicit
Sub vergleichen()
Dim varStation As Variant, varRet As Variant
Dim lngI As Long, lngN As Long
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlManual
End With
With Sheets("Station 000")
varStation = .Range("B2:C" & Application.Max(2, .Cells(.Rows.Count, 2).End(xlUp).Row))
Debug.Print varStation
For lngI = 1 To UBound(varStation, 1)
varRet = Application.Match(varStation(lngI, 1), Sheets("Bibliothek").Columns(2), 0)
If IsNumeric(varRet) Then
If varStation(lngI, 2) = Sheets("Bibliothek").Cells(varRet, 3) Then
'        .Range(.Cells(lngI + 1, 3), .Cells(lngI + 1, 10)).Copy Sheets("Bibliothek").Cells( _
varRet, 3)
.Range(.Cells(lngI + 1, 4), .Cells(lngI + 1, 11)).Copy Sheets("Bibliothek").Cells( _
varRet, 4)
End If
End If
Next
End With
ErrorHandler:
With Err
If .Number  0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'vergleichen'" & vbLf & String(25, Chr(151)) & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf & vbLf & String(25, Chr(151)), 81968, _
"VBA - Fehler in Prozedur - vergleichen", .HelpFile, .HelpContext
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
End With
End Sub

Anzeige

65 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige