Anzeige
Archiv - Navigation
1556to1560
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

Makro für Abgleich und Einfügen von Projektnamen

Makro für Abgleich und Einfügen von Projektnamen
17.05.2017 15:03:25
Projektnamen
Hallo,
ich suche ein Makro:
- In Spalte A sind nur harte Werte enthalten
- Es soll ein Abgleich der Projektnamen von A2-A16 mit A18-A32 vorgenommen werden
- Dabei dürfen bereits geschriebene Projektnamen in A18 - A32 nicht verändert oder versetzt werden
- Fehlende Projekte sollen im Level 2 entsprechend ans Ende angefügt werden (in dem Fall ab A22) mit harten Werten
- Das Wunschergebnis ist ab Zelle C18 dargestellt
DANKE
https://www.herber.de/bbs/user/113645.xlsx

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

Betreff
Datum
Anwender
Anzeige
AW: Makro für Abgleich und Einfügen von Projektnamen
18.05.2017 03:55:18
Projektnamen
Hallo Rene,
hier ein entsprechendes Makro
LG
Franz
Sub prcAbgleich()
Dim wksNeu As Worksheet, wksVergleich As Worksheet
Dim rngVergleich As Range
Dim rngSuchen As Range
Dim zeiVergleich As Long, zeiNeu As Long, Zeile As Long
Set wksNeu = ActiveSheet
Set wksVergleich = ActiveSheet
With wksNeu
'letzte Zeile mit neuen Daten ermitteln
zeiNeu = .Cells(1, 1).End(xlDown).Row
If zeiNeu > 16 Then
MsgBox "Keine neuen Daten", _
vbOKOnly + vbInformation, "Projekte abgleichen"
Exit Sub
End If
End With
With wksVergleich
'letzte Zeile mit Vergleichsdaten ermitteln und Vergleichsbereich setzen
zeiVergleich = .Cells(17, 1).End(xlDown).Row
If zeiVergleich > 32 Then
'noch keine Einträge im Vergleichsbereich
zeiVergleich = 17
Set rngVergleich = Nothing
Else
Set rngVergleich = .Range(.Cells(18, 1), .Cells(zeiVergleich, 1))
End If
End With
With wksNeu
'Daten Abgleichen
For Zeile = 2 To zeiNeu
Set rngSuchen = Nothing
If Not rngVergleich Is Nothing Then
'neuen Wert im Vergleichsbereich suchen
Set rngSuchen = rngVergleich.Find(what:=.Cells(Zeile, 1).Value, _
LookIn:=xlValues, _
lookat:=xlWhole)
End If
If rngSuchen Is Nothing Then
zeiVergleich = zeiVergleich + 1
wksVergleich.Cells(zeiVergleich, 1) = .Cells(Zeile, 1)
Else
'neuer Wert im Vergleichsbereich schon vorhanden
End If
Next Zeile
End With
End Sub

Anzeige
AW: Makro für Abgleich und Einfügen von Projektnamen
18.05.2017 13:11:53
Projektnamen
Hallo und vielen Dank,
die Zellbezüge im Sheet waren nur Beispielhaft.
Ich kenne mich mit Makro leider nicht aus...Daher habe ich nochmal ein Sheet gemacht mit den richtigen Bezügen.
https://www.herber.de/bbs/user/113673.xlsx
Können Sie mir bei der Anpassung helfen?
Besten Dank!
AW: Makro für Abgleich und Einfügen von Projektnamen
18.05.2017 22:59:50
Projektnamen
Hallo Rene,
hier das geänderte Makro.
Wenn sich die Zellbereiche ändern, dann musst du "nur" noch die Werte am Beginn des Makros anpassen.
LG
Franz
Sub prcAbgleich()
Dim wksNeu As Worksheet, wksVergleich As Worksheet
Dim rngVergleich As Range
Dim rngSuchen As Range
Dim zeiVergleich As Long, zeiNeu As Long, Zeile As Long
Dim spaNeu As Long, spaVergleich As Long
Dim zeiNeu_1 As Long, zeiNeu_L
Dim zeiVergleich_1 As Long, zeiVergleich_L As Long
spaNeu = 3              'Spalte C - Spalte mit den neuen Daten
zeiNeu_1 = 13           '1. Datenzeile Levl 1
zeiNeu_L = 263          'Letzte Datenzeile Levl 1
spaVergleich = 3        'Spalte C - Spalte mit den Vergleichsdaten
zeiVergleich_1 = 265    '1. Datenzeile Levl 2
zeiVergleich_L = 447    'Letzte Datenzeile Levl 2
Set wksNeu = ActiveSheet
Set wksVergleich = ActiveSheet
With wksNeu
'letzte Zeile mit neuen Daten ermitteln
zeiNeu = .Cells(zeiNeu_1 - 1, spaNeu).End(xlDown).Row
If zeiNeu > zeiNeu_L Then
MsgBox "Keine neuen Daten", _
vbOKOnly + vbInformation, "Projekte abgleichen"
Exit Sub
End If
End With
With wksVergleich
'letzte Zeile mit Vergleichsdaten ermitteln und Vergleichsbereich setzen
zeiVergleich = .Cells(zeiVergleich_1 - 1, spaVergleich).End(xlDown).Row
If zeiVergleich > zeiVergleich_L Then
'noch keine Einträge im Vergleichsbereich
zeiVergleich = zeiVergleich_1 - 1
Set rngVergleich = Nothing
Else
Set rngVergleich = .Range(.Cells(zeiVergleich_1, spaVergleich), _
.Cells(zeiVergleich, spaVergleich))
End If
End With
With wksNeu
'Daten Abgleichen
For Zeile = zeiNeu_1 To zeiNeu
Set rngSuchen = Nothing
If Not rngVergleich Is Nothing Then
'neuen Wert im Vergleichsbereich suchen
Set rngSuchen = rngVergleich.Find(what:=.Cells(Zeile, spaNeu).Value, _
LookIn:=xlValues, _
lookat:=xlWhole)
End If
If rngSuchen Is Nothing Then
zeiVergleich = zeiVergleich + 1
wksVergleich.Cells(zeiVergleich, spaVergleich) = .Cells(Zeile, spaNeu)
Else
'neuer Wert im Vergleichsbereich schon vorhanden
End If
Next Zeile
End With
End Sub

Anzeige
AW: Makro für Abgleich und Einfügen von Projektnamen
19.05.2017 08:13:03
Projektnamen
Wahnsinn! Vielen Dank!!

307 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige