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

Bitte mal drüber schauen

Bitte mal drüber schauen
10.08.2014 19:40:54
Laeubchen
Hallo,
es ist schon lang her, das ich mich mit Excel sowie VBA beschäftigt habe.
Nun habe ich ein wenig was zusammgebastelt.
Es wäre nett könnte Jemand so nett sein und mal rüber schauen, da ich mir nicht sicher bin, ob es Probleme geben kann und ob die Möglichkeit besteht, diesen Code etwas kürzer zu fassen.
Es handelt sich hierbei um Tabellenblätter (RT 1 und RT 2) die Daten enthalten, die später für den Ausdruck von Etiketten (Eti 1 und Eti 2) verwendet werden müssen.
So weit funktioniert die Datenübernahme.
Mein Problem ist ebenso, wenn eine Zeile mal freigelassen wird, so ist ein Etikett umsonst bzw mit den Grunddaten dazwischen. Das Problem besteht aber nur wenn keine Schweißnahtnummer mit der dazugehörigen Nennweite eingegeben wird. Das kann passieren, damit man den Überblick nicht verliert.
Ich hoffe ich konnte mich ein wenig verständlich ausdrücken und wäre für jeden guten Rat und Tipp dankbar.
Option Explicit
'Hiermit wird verlangt, dass alle benutzten Variablen definiert werden.

Sub ExportDaten()
' erstellt von Laeubchen
Application.ScreenUpdating = False
'Deaktiviert die Bildschirmaktualisierung während der Makro-Ausführung.
'Das Makro wird schneller ausgeführt und der Bildschirm flackert nicht.
' Schweißnahtnummer RT 1 Eti 1 FERTIG
Dim RngCopy As Range, RngPaste As Range
Dim aWerte()
Set RngCopy = Sheets("RT 1").Range("B28:F28")
Set RngPaste = Sheets("Eti 1").Range("B4:D4")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 1").Range("B29:F29")
Set RngPaste = Sheets("Eti 1").Range("I4:K4")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 1").Range("B30:F30")
Set RngPaste = Sheets("Eti 1").Range("B12:D12")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 1").Range("B31:F31")
Set RngPaste = Sheets("Eti 1").Range("I12:K12")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 1").Range("B32:F32")
Set RngPaste = Sheets("Eti 1").Range("B20:D20")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 1").Range("B33:F33")
Set RngPaste = Sheets("Eti 1").Range("I20:K20")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 1").Range("B34:F34")
Set RngPaste = Sheets("Eti 1").Range("B28:D28")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 1").Range("B35:F35")
Set RngPaste = Sheets("Eti 1").Range("I28:K28")
aWerte() = RngCopy
RngPaste = aWerte()
' Schweißnahtnummer RT 2 Eti 1 FERTIG
Set RngCopy = Sheets("RT 2").Range("B18:F18")
Set RngPaste = Sheets("Eti 1").Range("B36:F36")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B19:F19")
Set RngPaste = Sheets("Eti 1").Range("I36:K36")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B20:F20")
Set RngPaste = Sheets("Eti 1").Range("B44:B44")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B21:F21")
Set RngPaste = Sheets("Eti 1").Range("I44:K44")
aWerte() = RngCopy
RngPaste = aWerte()
' Schweißnahtnummer RT 2 Eti 2 FERTIG
Set RngCopy = Sheets("RT 2").Range("B22:F22")
Set RngPaste = Sheets("Eti 2").Range("B4:D4")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B23:F23")
Set RngPaste = Sheets("Eti 2").Range("I4:K4")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B24:F24")
Set RngPaste = Sheets("Eti 2").Range("B12:D12")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B25:F25")
Set RngPaste = Sheets("Eti 2").Range("I12:K12")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B26:F26")
Set RngPaste = Sheets("Eti 2").Range("B20:D20")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B27:F27")
Set RngPaste = Sheets("Eti 2").Range("I20:K20")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B28:F28")
Set RngPaste = Sheets("Eti 2").Range("B28:D28")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B29:F29")
Set RngPaste = Sheets("Eti 2").Range("I28:K28")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B30:F30")
Set RngPaste = Sheets("Eti 2").Range("B36:D36")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B31:F31")
Set RngPaste = Sheets("Eti 2").Range("B36:D36")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B32:F32")
Set RngPaste = Sheets("Eti 2").Range("I36:K36")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B34:F34")
Set RngPaste = Sheets("Eti 2").Range("B44:D44")
aWerte() = RngCopy
RngPaste = aWerte()
Set RngCopy = Sheets("RT 2").Range("B35:F35")
Set RngPaste = Sheets("Eti 2").Range("I44:K44")
aWerte() = RngCopy
RngPaste = aWerte()
' Nennweiten Eti 1 FERTIG
Dim Rng1Copy As Range, Rng1Paste As Range
Dim bWerte()
Set Rng1Copy = Sheets("RT 1").Range("M28:N28")
Set Rng1Paste = Sheets("Eti 1").Range("F5")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 1").Range("M29:N29")
Set Rng1Paste = Sheets("Eti 1").Range("M5")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 1").Range("M30:N30")
Set Rng1Paste = Sheets("Eti 1").Range("F13")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 1").Range("M31:N31")
Set Rng1Paste = Sheets("Eti 1").Range("M13")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 1").Range("M32:N32")
Set Rng1Paste = Sheets("Eti 1").Range("F21")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 1").Range("M33:N33")
Set Rng1Paste = Sheets("Eti 1").Range("M21")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 1").Range("M34:N34")
Set Rng1Paste = Sheets("Eti 1").Range("F29")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 1").Range("M35:N35")
Set Rng1Paste = Sheets("Eti 1").Range("M29")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
' Nennweiten Eti 1 RT 2
Set Rng1Copy = Sheets("RT 2").Range("M18:N18")
Set Rng1Paste = Sheets("Eti 1").Range("F37")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M19:N19")
Set Rng1Paste = Sheets("Eti 1").Range("M37")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M20:N20")
Set Rng1Paste = Sheets("Eti 1").Range("F45")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M21:N21")
Set Rng1Paste = Sheets("Eti 1").Range("M45")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
' Nennweiten Eti 2 RT 2
Set Rng1Copy = Sheets("RT 2").Range("M22:N22")
Set Rng1Paste = Sheets("Eti 2").Range("F5")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M23:N23")
Set Rng1Paste = Sheets("Eti 2").Range("M5")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M24:N24")
Set Rng1Paste = Sheets("Eti 2").Range("F13")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M25:N25")
Set Rng1Paste = Sheets("Eti 2").Range("M13")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M26:N26")
Set Rng1Paste = Sheets("Eti 2").Range("F21")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M27:N27")
Set Rng1Paste = Sheets("Eti 2").Range("M21")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M28:N28")
Set Rng1Paste = Sheets("Eti 2").Range("F29")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M29:N29")
Set Rng1Paste = Sheets("Eti 2").Range("M29")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M30:N30")
Set Rng1Paste = Sheets("Eti 2").Range("F37")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M31:N31")
Set Rng1Paste = Sheets("Eti 2").Range("M37")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M32:N32")
Set Rng1Paste = Sheets("Eti 2").Range("F45")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M33:N33")
Set Rng1Paste = Sheets("Eti 2").Range("M45")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M34:N34")
Set Rng1Paste = Sheets("Eti 2").Range("F44")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
Set Rng1Copy = Sheets("RT 2").Range("M35:N35")
Set Rng1Paste = Sheets("Eti 2").Range("M44")
bWerte() = Rng1Copy
Rng1Paste = bWerte()
'Nennweiten Format
Sheets("Eti 1").Range("F5, M5, F13, M13, F21, M21, F29, M29, F37, M37, F45, M45"). _
NumberFormat = """t = ""@ ""mm"""
Sheets("Eti 2").Range("F5, M5, F13, M13, F21, M21, F29, M29, F37, M37, F45, M45"). _
NumberFormat = """t = ""@ ""mm"""
'Grunddaten
'Projekt Eti 1
Set RngCopy = Sheets("RT 1").Range("AE6:AX6")
Set RngPaste = Sheets("Eti 1").Range("B2:D2, I2:K2, B10:D10, I10:K10,  B18:D18, I18:K18,     _
_
_
_
_
_
_
_
B26:D26, I26:K26, B34:D34, I34:I34, B42:D42, I42:I42")
aWerte() = RngCopy
RngPaste = aWerte()
'Projekt Eti 2
Set RngCopy = Sheets("RT 1").Range("AE6:AX6")
Set RngPaste = Sheets("Eti 2").Range("B2:D2, I2:K2, B10:D10, I10:K10,  B18:D18, I18:K18,     _
_
_
_
_
_
_
_
B26:D26, I26:K26, B34:D34, I34:I34, B42:D42, I42:I42")
aWerte() = RngCopy
RngPaste = aWerte()
'Prüfobjekt Eti 1
Set RngCopy = Sheets("RT 1").Range("AY6:BL6")
Set RngPaste = Sheets("Eti 1").Range("B3:D3, I3:K3, B11:D11, I11:K11,  B19:D19, I19:K19,     _
_
_
_
_
_
_
_
B27:D27, I27:K27, B35:D35, I35:I35, B43:D43, I43:I43")
aWerte() = RngCopy
RngPaste = aWerte()
'Prüfobjekt Eti 2
Set RngCopy = Sheets("RT 1").Range("AY6:BL6")
Set RngPaste = Sheets("Eti 2").Range("B3:D3, I3:K3, B11:D11, I11:K11,  B19:D19, I19:K19,     _
_
_
_
_
_
_
_
B27:D27, I27:K27, B35:D35, I35:I35, B43:D43, I43:I43")
aWerte() = RngCopy
RngPaste = aWerte()
'Schmitt-Nr. Eti 1
Set RngCopy = Sheets("RT 1").Range("BH4:BI4")
Set RngPaste = Sheets("Eti 1").Range("F1, M1, F9, M9, F17, M17, F25, M25, F33, M33, F41,  _
M41")
aWerte() = RngCopy
RngPaste = aWerte()
'Schmitt-Nr. Eti 2
Set RngCopy = Sheets("RT 1").Range("BH4:BI4")
Set RngPaste = Sheets("Eti 2").Range("F1, M1, F9, M9, F17, M17, F25, M25, F33, M33, F41,  _
M41")
aWerte() = RngCopy
RngPaste = aWerte()
'Auftrags-Nr. Eti 1
Set RngCopy = Sheets("RT 1").Range("M6:AD6")
Set RngPaste = Sheets("Eti 1").Range("F2, M2, F10, M10, F18, M18, F26, M26, F34, M34, F42,   _
_
_
_
_
_
_
_
M42")
aWerte() = RngCopy
RngPaste = aWerte()
'Auftrags-Nr. Eti 2
Set RngCopy = Sheets("RT 1").Range("M6:AD6")
Set RngPaste = Sheets("Eti 2").Range("F2, M2, F10, M10, F18, M18, F26, M26, F34, M34, F42,   _
_
_
_
_
_
_
_
M42")
aWerte() = RngCopy
RngPaste = aWerte()
'Berichts-Nr. Eti 1
Set RngCopy = Sheets("RT 1").Range("BK4:BL4")
Set RngPaste = Sheets("Eti 1").Range("F4, M4, F12, M12, F20, M20, F28, M28, F36, M36, F44,   _
_
_
_
_
_
_
_
M44")
aWerte() = RngCopy
RngPaste = aWerte()
'Berichts-Nr. Eti 2
Set RngCopy = Sheets("RT 1").Range("BK4:BL4")
Set RngPaste = Sheets("Eti 2").Range("F4, M4, F12, M12, F20, M20, F28, M28, F36, M36, F44,   _
_
_
_
_
_
_
_
M44")
aWerte() = RngCopy
RngPaste = aWerte()
'Datum Eti 1 mit Formatierung des Datums
Set RngCopy = Sheets("RT 1").Range("AP10:AX10")
Set RngPaste = Sheets("Eti 1").Range("D5, K5, D13, K13, D21, K21, D29, K29, D37, K37, D45,   _
_
_
_
_
_
_
_
K45")
Range("D5, K5, D13, K13, D21, K21, D29, K29, D37, K37, D45, K45").NumberFormat = "dd/mm/ _
yyyy;@"
aWerte() = RngCopy
RngPaste = aWerte()
'Datum Eti 2 mit Formatierung des Datums
Set RngCopy = Sheets("RT 1").Range("AP10:AX10")
Set RngPaste = Sheets("Eti 2").Range("D5, K5, D13, K13, D21, K21, D29, K29, D37, K37, D45,   _
_
_
_
_
_
_
_
K45")
Range("D5, K5, D13, K13, D21, K21, D29, K29, D37, K37, D45, K45").NumberFormat = "dd/mm/ _
yyyy;@"
aWerte() = RngCopy
RngPaste = aWerte()
Application.CutCopyMode = False:  Application.ScreenUpdating = True
'Die Kopiermarkierung aufheben und die Bildschirmaktualisierung wieder aktivieren
End Sub

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Tip: Schleife
11.08.2014 07:25:34
MCO
Guten Morgen!
Es ist wahrscheinlich nicht schneller aber wesentlich übersichtlicher, wenn du für das Beschreiben des Label-Sheets eine Schleife benutzt.
Für jedes Blatt würde ich an deiner Stelle eine neue Schleife bauen, es sei denn, du willst schon mit arrays arbeiten :-)
Die Schleife geht die Variablen 0 bis 5 durch. Die Variable X gibt den Versatz zur originalen zeile an. Damit gehe ich beim kopieren JEDE Zeile durch (eine Bedingung zum überspringen leerer Zeilen fehlt noch) beim Einfügen wird die Einfügezeile mit jedem Durchlauf einer geraden Zahl (x = 0, 2, 4, 6 usw) um x + 8 weitere Zeilen versetzt, ungerade um x + 7 (weil "x" 1 Zähler höher ist).
Anschließend werden die Werte wie gewohnt eingefügt.
Probiers mal aus, dann wird's deutlicher. (Einzelschritt mit F8)
Poste mal, wenn du's soweit hast. Vielleicht läßt sich dieses Prinzip ja auch auf den Rest vom Code ableiten...
Gruß, MCO

Dim RngCopy As Range, RngPaste As Range
Dim aWerte()
For x = 0 To 5
Set RngCopy = Sheets("RT 1").Range("B28:F28").Offset(x, 0)
With Sheets("Eti 1")
If WorksheetFunction.Even(x) = x Then 'prüft ob gerade oder ungerade
Set RngPaste = .Range("B4:D4").Offset(x * 8, 0)
Else
Set RngPaste = .Range("I4:K4").Offset((x-1) * 8, 0)
End If
End With
aWerte() = RngCopy
RngPaste = aWerte()
Next x

Anzeige
AW: Tip: Schleife
12.08.2014 13:11:37
Laeubchen
Hallo MCO,
vielen Dank für Dein Feedback.
Ich kann leider nicht immer gleich antworten, da ich arbeitsmäßig immer außerhalb bin.
Folgende Fehlermeldung kommt bei meinem ersten Versuch:
aWerte() = RngCopy
Laufzeitfehler '13' Typen unverträglich.
Es wäre nett, könntest Du mir vielleicht einen Tipp geben.
Gruß
Laeubchen

AW: Tip: Schleife
15.08.2014 23:41:54
Gerold
Hallo Laeubchen
Bei aWerte() wurde kein Typ angelegt (Dim aWerte() as Range)
Ausserdem können keine 5 Werte aus [Sheets("RT 1").Range("B28:F28")]
in drei Zellen [Sheets("Eti 1").Range("B4:D4")]untergebracht werden.
Vieleicht so mit Schleifen, siehe MCO.

Option Explicit
Sub test()
Dim x As Variant
For x = 0 To 5
Sheets("RT 1").Range("B28:F28").Offset(x, 0).Copy
Worksheets("Eti 1").Select
With ActiveSheet
If WorksheetFunction.Even(x) = x Then 'prüft ob gerade oder ungerade
.Range("B4").Offset(x * 8, 0).Select
ActiveSheet.Paste
Else
.Range("I4").Offset((x - 1) * 8, 0).Select
ActiveSheet.Paste
End If
End With
Next x
Application.CutCopyMode = False
End Sub
Gruß Gerold
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige