SelectionChange u Datenbereiche teilen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

If Target.Cells.Address = "$S$7" Then Range("B44").Select If Target.Cells.Address = "$S$8" Then Range("B45").Select If Target.Cells.Address = "$S$9" Then Range("B46").Select If Target.Cells.Address = "$S$10" Then Range("B47").Select If Target.Cells.Address = "$S$11" Then Range("B48").Select If Target.Cells.Address = "$S$12" Then Range("B49").Select If Target.Cells.Address = "$S$13" Then Range("B50").Select If Target.Cells.Address = "$S$14" Then Range("B51").Select If Target.Cells.Address = "$S$15" Then Range("B52").Select If Target.Cells.Address = "$S$16" Then Range("B53").Select If Target.Cells.Address = "$S$926" Then Range("B963").Select

Hallo Michael
ich habe den Thread gelesen und gehe mal auf das 1. Problem ein. Das Kopieren in Bezirk A+B.
Aus deiner Aufgabenstellung wurde ich nicht ganz schlau, weil sich da m.E. Bereiche überschneiden?
Hier (Verteilung) B6:R21 kopieren und in Mappe Bezirk_A (Verteilung) B6:R21 als Werte einfügen
Hier (Verteilung) B6:R6 und B22:R38 kopieren und in Mappe Bezirk_A (Verteilung) B6:R23 als Werte einfügen

Im Beispiel findest du drei neue Module, das 3. Modul als Test Modul um Offset Bereiche zu testen. Wir kopieren die ganze Tabelle nicht indem man 25 Makros schreibt für jeden einzelnen Range Bereich. Wir definineren Bereich die sich stufenweise wiederholen indem wir den Next Block über Offset auswaehlen. Dieses Verfahren über For Next und Offset dürfte dir wahrscheinlich neu sein.
Es ist mir zuviel Aufwand das ganze Makro für dich au schreiben. Wenn du das System aber verstanden hast schreibst du es selbst, und das sogar Professionell! Man muss das System der For Next Schleife mit Offset nur erst mal verstehen.
Wir verzichten beim kopieren alle auf Select, haengen ".Copy" ellegant an Rang dran! Zum Testen ob Kopierbereich und Einfügebereich stimmen benutze ich aber auch Select, um mir die Bereich optisch anzusehen. Aber nur in der Entwickungsphase des Makros!
Also, hier eine Beispieldatei zum spielen. Sum Testen kannst du die Orişginal Daten in zwei Beispiel Dateien für Bezirk A+B laden, und dann solange im Beispiel testen und kopieren bis es klappt. Bitte erst dann das Makro ins Original übernehmen. So zerstörst du dir beim Entwickeln keine Originaldaten!! Das ist sonst GROSSER Mist!!
Wenn es dir hilft kannst du den Thread ja schliessen, kein Haeckchen mehr setzen.
mfg Piet
https://www.herber.de/bbs/user/126322.xlsm

Hallo Piet
Vielen Dank dafür das du dich für mein Anliegen Interessierst.
Habe deine Mappe mit den neuen Modulen ausprobiert. Habe auch "fast" verstanden was du geschrieben hast. Module1 habe ich angepasst und funktioniert auch.

Const WBzA = "Bezirk_A.xlsm"    'Hier eure Datei Namen angeben
Const WBzB = "Bezirk_B.xlsm"    'für Bezirk A + Bezirk B
'1)Hier (Verteilung) B6:R21 kopieren und in Mappe Bezirk_A (Verteilung) B6:R21 als Werte einfü _
gen
'Sorry. Schreibfehler in Zeile 2) Statt Bezirk_A sollte es Bezirk_B sein
'2)Hier (Verteilung) B6:R6 und B22:R38  kopieren und in Mappe Bezirk_B (Verteilung) B6:R23 als  _
Werte einfügen
'Dann
'3)Hier (Verteilung) B43:R58 kopieren und in Mappe Bezirk_A (Verteilung) B28:R43 als Werte einfü _
gen
'Sorry. Schreibfehler in Zeile 4) Statt Bezirk_A sollte es Bezirk_B sein
'4)Hier (Verteilung) B43:R43 und B59:R75  kopieren und in Mappe Bezirk_B (Verteilung) B28:R45  _
als Werte einfügen
Sub Daten_verteilen()
Dim BezA As Object
Dim BezB As Object
'Arb.Mappen A+B als Objekte zuweisen
Set BezA = Workbooks(WBzA).Worksheets("Verteilung")
Set BezB = Workbooks(WBzB).Worksheets("Verteilung")
With ThisWorkbook.Worksheets("Verteilung")
'** alle Bereiche mit "." davor beziehen sich auf die With Tabelle!!
'1. Korrekte Aufteilung für die erste Quell-Tabelle auf die beiden Ziele
'Bezirk_A
.Range("B6:R21").Copy  'in Master kopieren, als Werte einfügen
BezA.Range("B6:R21").PasteSpecial xlPasteValues
'Bezirk_B
.Range("B6:R6").Copy  'in Master kopieren, als Werte einfügen
BezB.Range("B6:R6").PasteSpecial xlPasteValues
.Range("B22:R38").Copy  'in Master kopieren, als Werte einfügen
BezB.Range("B7:R23").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
End Sub

Module2+3 bekomme ich aber nicht zum Laufen. Da wäre noch ein wenig Hilfe willkommen.
Module2
Laufzeitfehler '91':
Objektvariable oder With-Blockvariable nicht festgelegt
Gelbe Debug Zeile: BezA.Range("B6:R21").Offset(j * 37, 0).PasteSpecial xlPasteValues
******************************************************************************
Module3
Fehler beim Kompilieren:
Variable nicht definiert
Gelbe Debug Zeile: Sub Quelle_Offset_Test_zumDaten_kopieren()
Das "j" ist Markiert
******************************************************************************
Kannst du da nochmals drüberschauen?
Viele Grüße
Michael

Sub Quelle_Offset_Test_zumDaten_kopieren() Dim j 'For Next zum Offset testen ob er stimmt!! For j = 0 To 24 'für 24 Tabellen Bereiche If .Range("B6").Offset(j * 37, 0) = "" Then Exit For .Range("B6:R21").Offset(j * 37, 0).Select Selection.Copy If j > 20 Then MsgBox Selection.Address(0, 0) Next j End Sub

Const WBzA = "Bezirk_A.xlsm" 'Hier die Datei Namen angeben Const WBzB = "Bezirk_B.xlsm" 'für Bezirk A + Bezirk B Sub Daten_verteilen() Dim BezA As Object Dim BezB As Object Dim j 'Arb.Mappen A+B als Objekte zuweisen Set BezA = Workbooks(WBzA).Worksheets("Verteilung") Set BezB = Workbooks(WBzB).Worksheets("Verteilung") Application.ScreenUpdating = False With ThisWorkbook.Worksheets("Verteilung") For j = 0 To 25 'für 26 Tabellen Bereiche 'Bezirk_A funktioniert wenn Bezirk_B heraus Kommentiert ist Range("B6:R21").Offset(j * 37, 0).Copy BezA.Range("B6:R21").Offset(j * 22, 0).PasteSpecial xlPasteValues Next j 'Bezirk_B funktioniert wenn Bezirk_A heraus Kommentiert ist ' Range("B6:R6").Offset(j * 37, 0).Copy ' BezB.Range("B6:R6").Offset(j * 22, 0).PasteSpecial xlPasteValues ' Range("B22:R38").Offset(j * 37, 0).Copy ' BezB.Range("B7:R23").Offset(j * 22, 0).PasteSpecial xlPasteValues ' Next j End With Application.ScreenUpdating = True End Sub

Sub Daten_verteilen() Dim BezA As Object Dim BezB As Object Dim j 'Arb.Mappen A+B als Objekte zuweisen Set BezA = Workbooks(WBzA).Worksheets("Verteilung") Set BezB = Workbooks(WBzB).Worksheets("Verteilung") Application.ScreenUpdating = False With ThisWorkbook.Worksheets("Verteilung") For j = 0 To 25 'für 26 Tabellen Bereiche 'Bezirk_A funktioniert wenn Bezirk_B heraus Kommentiert ist Range("B6:R21").Offset(j * 37, 0).Copy BezA.Range("B6:R21").Offset(j * 22, 0).PasteSpecial xlPasteValues Next j For j = 0 To 25 'für 26 Tabellen Bereiche 'Bezirk_B funktioniert wenn Bezirk_A heraus Kommentiert ist Range("B6:R6").Offset(j * 37, 0).Copy BezB.Range("B6:R6").Offset(j * 22, 0).PasteSpecial xlPasteValues Range("B22:R38").Offset(j * 37, 0).Copy BezB.Range("B7:R23").Offset(j * 22, 0).PasteSpecial xlPasteValues Next j End With Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

SelectionChange u Datenbereiche teilen

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread