Excel Bereich untereinander kopieren mit Msg Box

Forumthread: Excel Bereich untereinander kopieren mit Msg Box

18.11.2015 22:07:08

Max

Hallo zusammen,
ich würde gerne folgendes Durchführen, bekomme es aber leider nicht hin:
Ich habe in eine Tab in dem Bereich A7:BB45 Inhalte (Werte+Formeln) stehen und würde diesen gerne ab Zeile 46 so oft untereinander kopieren, wie ich in einer Inputbox eingebe.
Bekomme es leider nicht hin. Hoffe ihr könnt mir weiterhelfen!
Vielen Dank!!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Excel Bereich untereinander kopieren mit Msg Box

18.11.2015 22:52:44

Mullit

Hallo,
im Prinzip so:

Option Explicit

Public Sub test()
Dim lngIndex As Long
Application.ScreenUpdating = False
For lngIndex = 1 To Application.InputBox(Prompt:="Bitte Anzahl eingeben.", Title:="Kopien", Type:=1)
   With ActiveSheet
       Call .Cells(7, 1).Resize(39, 54).Copy(Destination:= _
           .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1))
   End With
Next
Application.ScreenUpdating = True
End Sub



VBA/HTML - CodeConverter für Office-Foren

AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel


Code erstellt und getestet in Office 12

Gruß, Mullit

AW: Excel Bereich untereinander kopieren mit Msg Box

18.11.2015 23:23:57

Sepp

Hallo Max,
so?

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub BereichKopieren()
Dim rng As Range
Dim lngAnswer As Long, lngStart As Long, lngC As Long

With Sheets("Tabelle3") 'Tabellenname anpassen!
  
  Set rng = .Range("A7:BB45")
  
  lngStart = rng.Cells(rng.Rows.Count, 1).Row + 1
  
  lngAnswer = Application.InputBox("Wie oft?", "Bereich kopieren", 1, Type:=2)
  
  If lngAnswer <> False Then
    If rng.Rows.Count * lngAnswer + lngStart > .Rows.Count Then
      MsgBox "sorry, that's too much!", vbExclamation
    ElseIf lngAnswer > 0 Then
      For lngC = 1 To lngAnswer
        rng.Copy .Cells(lngStart, rng.Cells(1, 1).Column)
        lngStart = lngStart + rng.Rows.Count + 1
      Next
    End If
  End If
End With
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Excel Bereich untereinander kopieren mit Msg Box

Forumthread: Excel Bereich untereinander kopieren mit Msg Box

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Excel Bereich untereinander kopieren mit Msg Box

Forumthread: Excel Bereich untereinander kopieren mit Msg Box

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread