Makro ergänzen

Question

Hallo Helfer,
das folgende Makro hatte Oliver "Coros" vor einiger Zeit für mich erstellt. In einer neuen Datei bräuchte ich eine Variante, wo nicht die ganze Spalte kopiert wird sondern nur Zeile 5 bis 99, und in der Zieltabelle nur die Werte, ohne Formatierung, eingefügt werden.

Sub Spalten_kopieren()
Dim intColumn As Integer
Dim intSheets As Integer
Dim strColumnEingabe As String

strColumnEingabe = InputBox("Bitte geben Sie die Spalte ein, in das die Daten eingefügt werden sollen", "Spaltenabfrage...", "A")
If strColumnEingabe = "" Then Exit Sub
If IsNumeric(strColumnEingabe) Then
MsgBox "Eingabe entspricht nicht der Gültigkeit. Bitte starten Sie die Funktion neu." & vbLf & vbLf _
& "Vorgang wird abgebrochen...", vbInformation, "falsche Eingabe..."
Exit Sub
End If

For intColumn = 3 To ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
For intSheets = 1 To Sheets.Count
If Sheets(intSheets).Name = ActiveSheet.Cells(1, intColumn) Then
ActiveSheet.Columns(intColumn).Copy _
Sheets(intSheets).Columns(CInt(Range(strColumnEingabe & 1).Column))
End If
Next intSheets
Next intColumn

End Sub

Answer 1

Hallo woher,

nachfolgend mal der Code (ungetetstet)

Sub Spalten_kopieren()
Dim intColumn As Integer
Dim intSheets As Integer
Dim strColumnEingabe As String

strColumnEingabe = InputBox("Bitte geben Sie die Spalte ein, in das die Daten eingefügt werden sollen", "Spaltenabfrage...", "A")
If strColumnEingabe = "" Then Exit Sub
If IsNumeric(strColumnEingabe) Then
MsgBox "Eingabe entspricht nicht der Gültigkeit. Bitte starten Sie die Funktion neu." & vbLf & vbLf _
& "Vorgang wird abgebrochen...", vbInformation, "falsche Eingabe..."
Exit Sub
End If

For intColumn = 3 To ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
For intSheets = 1 To Sheets.Count
If Sheets(intSheets).Name = ActiveSheet.Cells(1, intColumn) Then
ActiveSheet.Range(Cells(5, intColumn), Cells(99, intColumn)).Copy
Sheets(intSheets).Columns(CInt(Range(strColumnEingabe & 1).Column)).PasteSpecial Paste:=xlPasteValues
End If
Next intSheets
Next intColumn

End Sub

MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 2

Hallo Oliver,
vielen Dank für die schnelle Antwort.
Leider hatte ich in meiner Frage vergessen zu sagen, das auch das Einfügen der Daten ab Zeile 6 erfolgen soll. Also muss wohl in diese Zeile irgendwo eine "6" rein:

Sheets(intSheets).Columns(CInt(Range(strColumnEingabe & 1).Column)).

mfg
Wolfgang

Answer 3

Hallo Wolfgang!

Dann müsste das Makro so aussehen (wieder ungestetet):

Sub Spalten_kopieren()
Dim intColumn As Integer
Dim intSheets As Integer
Dim strColumnEingabe As String

strColumnEingabe = InputBox("Bitte geben Sie die Spalte ein, in das die Daten eingefügt werden sollen", "Spaltenabfrage...", "A")
If strColumnEingabe = "" Then Exit Sub
If IsNumeric(strColumnEingabe) Then
MsgBox "Eingabe entspricht nicht der Gültigkeit. Bitte starten Sie die Funktion neu." & vbLf & vbLf _
& "Vorgang wird abgebrochen...", vbInformation, "falsche Eingabe..."
Exit Sub
End If

For intColumn = 3 To ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
For intSheets = 1 To Sheets.Count
If Sheets(intSheets).Name = ActiveSheet.Cells(1, intColumn) Then
ActiveSheet.Range(Cells(5, intColumn), Cells(99, intColumn)).Copy
Sheets(intSheets).Cells(6, (CInt(Range(strColumnEingabe & 1).Column))).PasteSpecial Paste:=xlPasteValues
End If
Next intSheets
Next intColumn

End Sub

MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 4

Hallo Oliver,

Danke, perfekt!

mfg

Wolfgang