Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1708to1712
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

Daten vergleichen und übertragen

Daten vergleichen und übertragen
30.08.2019 06:38:49
parza
Hallo Piet, hallo Fachleute,
ich mache einen Beitrag, den ich eigentlich schon geschlossen hatte, weil du und Werner ihn schon gelöst haben, nun doch nochmal auf (komme beim Anpassen an die Originaldatei an meine Grenzen).Den zugehörigen ersten Beitrag findet man am 28.08.19.
Soweit konnte ich alles in meine Originaldatei anpassen, aber es sind in der Originaldatei, wie Werner schon angedeutet hat, manchmal mehr Daten zum Einfügen. Die neue hochgeladene Datei entspricht jetzt der eigentlichen Größe zum Einfügen.
Wäre schön, wenn du (oder jemand, der kompetenter ist als ich) das noch anpassen könntest.
Vielen Dank, parza
https://www.herber.de/bbs/user/131718.xlsx

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Daten vergleichen und übertragen
30.08.2019 09:14:24
ede
Hallo parza,
anbei mal ein geänderter Code (von Piet), wobei ich keinen Wert auf Schönheit gelegt habe.

Sub Filiale_einzeln_auflisten_ede()
Dim f, lzJ, lz1 As Long, lz3 As Long
Dim a As Long, k As Long, j As Long
Dim spJ As Long, y As Long, zeile As Long
'LastZeile in Spalten
lz1 = Cells(Rows.Count, 1).End(xlUp).Row
lz3 = Cells(Rows.Count, 3).End(xlUp).Row
lzJ = Cells(Rows.Count, 11).End(xlUp).Row
'alte Tabelle löschen, aussr Copy Bereich!
Range("J2:R" & lzJ).Clear
Application.ScreenUpdating = False
spJ = 10
zeile = 2
'Schleife für Filialen in Spalte A
For f = 2 To lz1
'Filialen-Kopf setzen
Cells(zeile, spJ) = Cells(f, 1)
Cells(zeile, spJ + 1) = Cells(1, 4)
Cells(zeile, spJ + 2) = Cells(1, 5)
Cells(zeile, spJ + 3) = Cells(1, 6)
Cells(zeile, spJ + 4) = Cells(1, 7)
Cells(zeile, spJ + 5) = Cells(1, 8)
zeile = zeile + 1
'für jeden Bewegungssatz in Spalte C
For y = 2 To lz3
If Cells(f, 1) = Cells(y, 3) Then
Cells(zeile, spJ + 1) = Cells(y, 4)
Cells(zeile, spJ + 2) = Cells(y, 5)
Cells(zeile, spJ + 3) = Cells(y, 6)
Cells(zeile, spJ + 4) = Cells(y, 7)
Cells(zeile, spJ + 5) = Cells(y, 8)
zeile = zeile + 1
End If
Next y
zeile = zeile + 2
Next f
Application.ScreenUpdating = True
End Sub

Anzeige
AW: Daten vergleichen und übertragen
30.08.2019 11:07:03
parza
Ede danke,
die Lösung von Piet ist die eigentlich gesuchte, da diese tatsächlich für jede Filiale eine Vorlage mit Rahmen, gelber Hinterlegung usw. erstellt. Mein Wunsch wäre "nur", dass es nicht 5 Zeilen, sondern 10 Zeile zu befüllen sind.
Das ist der Code von Piet:
Option Explicit '28.8.2019 Piet für Herber Forum
Const CopyBer = "J2:O7" 'Copy Bereich; wird nach unten kopiert
Const X = 2 'Anzahl Leerzeilen zwischen Feldern
Sub Filiale_einzeln_auflisten()
Dim f, lzJ, lz1 As Long, lz3 As Long
Dim a As Long, k As Long, j As Long
Dim l As Long, y As Long, z As Long
'LastZell in Spalten A,C,K ermitteln
lz1 = Cells(Rows.Count, 1).End(xlUp).Row
lz3 = Cells(Rows.Count, 3).End(xlUp).Row
lzJ = Cells(Rows.Count, 11).End(xlUp).Row
If lzJ  3 Then Range(CopyBer).Copy Cells(z, 10)
Cells(z + 1, 10).Resize(5, 6) = Empty
'Copy Bereich Überschrift einsetzen
Cells(z, 10) = Cells(k, 1)
'** Filialen -Mit Daten- auflisten Spalte Q
Cells(f, 17) = Cells(k, 1)    '** oder löschen
f = f + 1: z = z + 1: y = z
'Schleife für Daten in Spalte C, D-H
For j = a To lz3
If Cells(k, 1)  Cells(j, 3) Then Exit For
'Datensatz kopieren, z = Next Zeile
Cells(j, 4).Resize(1, 5).Copy
Cells(z, 11).PasteSpecial xlPasteValues
z = z + 1
Next j: a = j:
Application.CutCopyMode = False
z = y + 5 + X  'z auf Next Copy Feld setzen
Else  'Filialen ohne Daten auflisten Spalte R
Cells(l, 18) = Cells(k, 1)    '** oder löschen
l = l + 1
End If
Next k
End Sub

Anzeige
AW: Daten vergleichen und übertragen
30.08.2019 11:11:11
ede
Hallo nochmal,
den Code von Piet hatte ich auch gelesen, aber mich für eigenen etwas abgeleiteten entschieden, anbei mit Formatierung im 10er Block (kannst du anpassen):

Option Explicit
Const blocksatz = 10                'Anzahl Zeilen je Filiale
Sub Filiale_einzeln_auflisten_ede_fest()
Dim f, lzJ, lz1 As Long, lz3 As Long
Dim a As Long, k As Long, j As Long
Dim spJ As Long, y As Long, zeile As Long
'LastZeile in Spalten
lz1 = Cells(Rows.Count, 1).End(xlUp).Row
lz3 = Cells(Rows.Count, 3).End(xlUp).Row
lzJ = Cells(Rows.Count, 11).End(xlUp).Row
'alte Tabelle löschen, aussr Copy Bereich!
Range("J2:R" & lzJ).Clear
Application.ScreenUpdating = False
spJ = 10
zeile = 2
'Schleife für Filialen in Spalte A
For f = 2 To lz1
'Filialen-Kopf setzen
Range("C1:H1").Copy
Range(Cells(zeile, spJ), Cells(zeile, spJ + 5)).PasteSpecial Paste:=xlPasteFormats
Cells(zeile, spJ) = Cells(f, 1)
Cells(zeile, spJ + 1) = Cells(1, 4)
Cells(zeile, spJ + 2) = Cells(1, 5)
Cells(zeile, spJ + 3) = Cells(1, 6)
Cells(zeile, spJ + 4) = Cells(1, 7)
Cells(zeile, spJ + 5) = Cells(1, 8)
zeile = zeile + 1
a = 0
'für jeden Bewegungssatz in Spalte C
For y = 2 To lz3
If Cells(f, 1) = Cells(y, 3) Then
Cells(y, 4).Resize(1, 5).Copy
Cells(zeile, spJ + 1).PasteSpecial
zeile = zeile + 1
a = a + 1
End If
Next y
zeile = zeile + (blocksatz - a)
Next f
Application.ScreenUpdating = True
End Sub

Anzeige
AW: Daten vergleichen und übertragen
30.08.2019 11:47:39
parza
Ede, ich glaube es funktioniert super!! Ausgiebiger Test am Wochenende.
Wie gern würde ich verstehen, was ihr da so schreibt. Aber dafür bin ich wahrscheinlich zu alt.
Schönes Wochenende und vielen Dank
parza
gerne und Danke für die Rückinfo (o.T.)
30.08.2019 11:58:50
ede
.

307 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige