Daten transportieren

Forumthread: Daten transportieren

02.03.2008 00:50:00

Dieter.G

Hallo zusammen,
ich brauche mal wieder Euere Hilfe.
Mein Problem hab ich in der Beispielmappe beschrieben!

Die Datei https://www.herber.de/bbs/user/50340.xls wurde aus Datenschutzgründen gelöscht

Danke im Voraus
Gruß Dieter

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Daten transportieren

02.03.2008 01:15:00

chris
AW: Daten transportieren

02.03.2008 10:37:00

Dieter.G
AW: Daten transportieren

02.03.2008 10:42:00

Herby
AW: Daten transportieren

02.03.2008 11:41:00

Dieter.G
AW: Daten transportieren

02.03.2008 12:07:54

Herby
AW: Daten transportieren

02.03.2008 11:35:00

Erich
AW: Daten transportieren

02.03.2008 12:03:00

Dieter.G
AW: Daten transportieren

02.03.2008 12:05:00

Erich

AW: Daten transportieren

02.03.2008 01:15:00

chris

Hallo Dieter,
was hälst du davon ?
Hoffe es hilft Dir.
Ich habe es mal auf die schnelle erstellt.
Ohne größere fehlerabfragen.
https://www.herber.de/bbs/user/50341.xls
gruß Chris

AW: Daten transportieren

02.03.2008 10:37:00

Dieter.G

Hallo Chris,
funktioiert im Prinzip, es wäre aber für mich wichtig, die Zellen (Kalenderwochen) die transportiert werden sollen nur zu markieren anstatt die Daten in eine MsgBox einzugeben!
Gruß Díeter

AW: Daten transportieren

02.03.2008 10:42:00

Herby

Hallo Dieter,
anbei das Makro von Chris mit einer kleinen Änderung. Zuerst die
Inputbox aufrufen, dann den gewünschten Bereich markieren und
dann wird transponiert.
https://www.herber.de/bbs/user/50344.xls
viele Grüße
Herby

AW: Daten transportieren

02.03.2008 11:41:00

Dieter.G

Hallo Herby,
wie gesagt, am besten wäre das ganze ohne InputBox.
Wenn das nicht möglich ist, dann müßte bei Deiner Version noch die Meldung, wenn ich bei der InputBox auf "OK" Klicke aber nichts markiert wurde, durch einen Hinweis z.B. "Es wurden noch keine Kalenderwochen markiert" ersetzt werden.
Wenn ich wenn ich bei der InputBox auf "Abbrechen" Klicke 'Laufzeitfehler 424': "Objekt erforderlich" abgefangen werden.
Danke
Gruß Dieter

AW: Daten transportieren

02.03.2008 12:07:54

Herby

Hallo Dieter,
mit Fehlerabfrangroutine:
https://www.herber.de/bbs/user/50350.xls
Viele Grüße
Herby

AW: Daten transportieren

02.03.2008 11:35:00

Erich

Hallo Dieter,
hier noch ne Alternative. Die Prozedur geht davon aus, dass die zu kopierenden Zeilen
VOR dem Aufruf selektiert wurden.
Sie verträgt auch Mehrfachselektionen:


Option Explicit
Sub transport2()
Dim rngSel As Range, rngAr As Range, intC As Integer
If Intersect(Selection, Columns(2)) Is Nothing Then Exit Sub
Set rngSel = Intersect(Selection, Columns(2))
If rngSel.Count > 15 Then
MsgBox ("mehr als 15 Kalenderwochen")
Exit Sub
End If
Application.ScreenUpdating = False
With Sheets("Tabelle2")
.Range("C4:Q16").ClearContents
intC = 3
For Each rngAr In rngSel.Areas
Range(Cells(rngAr.Row, 2), Cells(rngAr.Row + rngAr.Rows.Count - 1, 14)).Copy
.Cells(4, intC).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
intC = intC + rngAr.Rows.Count
Next rngAr
Application.CutCopyMode = False
.Select                             ' nur wenn nötig/gewünscht
.Cells(1, 1).Select                 ' nur wenn nötig/gewünscht
End With
Application.ScreenUpdating = True
End Sub

Und hier die Mappe zum Testen:
https://www.herber.de/bbs/user/50347.xls
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

AW: Daten transportieren

02.03.2008 12:03:00

Dieter.G

Hallo Erich,
vielen Dank, Deine Lösung ist perfekt!!
Danke aber auch an die anderen beiden.
Gruß Dieter

AW: Daten transportieren

02.03.2008 12:05:00

Erich

Hallo Dieter,
hier noch eine Version mit Hinweis, wenn keine KW ausgewählt ist:


Sub transport2()
Dim rngSel As Range, rngAr As Range, intC As Integer
If Intersect(Selection, Columns(2)) Is Nothing Then
MsgBox ("Keine Kalenderwoche ausgewählt")
Exit Sub
End If
Set rngSel = Intersect(Selection, Columns(2))
If rngSel.Count > 15 Then
MsgBox ("mehr als 15 Kalenderwochen")
Exit Sub
End If
Application.ScreenUpdating = False
With Sheets("Tabelle2")
.Range("C4:Q16").ClearContents
intC = 3
For Each rngAr In rngSel.Areas
Range(Cells(rngAr.Row, 2), Cells(rngAr.Row + rngAr.Rows.Count - 1, 14)).Copy
.Cells(4, intC).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
intC = intC + rngAr.Rows.Count
Next rngAr
Application.CutCopyMode = False
.Select                             ' nur wenn nötig/gewünscht
.Cells(1, 1).Select                 ' nur wenn nötig/gewünscht
End With
Application.ScreenUpdating = True
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

Forumthread: Daten transportieren

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread