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

VBA; nur verschiedene markierte Zellen kopieren

VBA; nur verschiedene markierte Zellen kopieren
07.10.2017 17:54:51
Bernd
Hallo zusammen,
Benötige Hilfe bei folgendem Problem.
1.Kopiere markierte Zellen aus Spalte B3:B7, D3:D7, F3:F7, H3:H7.
2. Füge kopierte Zellen in Tabelle2 ab A3 abwärts ein
Die markierten Zellen in den Spalten variieren von der Anzahl und zwar kann z.B. in Spalte B drei Zellen, in Spalte D zwei Zellen usw. markiert sein.
Ich hoffe mich einigermaßen klar ausgedrückt zu haben. Danke schon mal im Voraus!!!
Grüße aus Bremen
Bernd
Office 2016 Pro 32bit

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA; nur verschiedene markierte Zellen kopieren
07.10.2017 18:07:33
Sepp
Hallo Bernd,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub copySelectedCells()
Dim objRange As Object, objCell As Object, varOutput() As Variant, lngIndex As Long

On Error Resume Next
Set objRange = Intersect(Selection, Sheets("Tabelle1").Range("B3:B7,D3:D7,F3:F7,H3:H7")).Cells
On Error GoTo 0

If Not objRange Is Nothing Then
  Redim varOutput(1 To objRange.Cells.Count, 1 To 1)
  For Each objCell In objRange
    lngIndex = lngIndex + 1
    varOutput(lngIndex, 1) = objCell.Value
  Next
  Sheets("Tabelle2").Range("A3").Resize(lngIndex, 1) = varOutput
End If


Set objRange = Nothing
End Sub

Gruß Sepp

Anzeige
AW: VBA; nur verschiedene markierte Zellen kopieren
07.10.2017 18:42:11
Bernd
Hallo Sepp,
Danke für deine schnelle Antwort.
Im VBE wird Fehler angezeigt und zwar in den 2 Zeile (Syntaxfehler)

  Redim varOutput(1 To objRange.Cells.Count, 1 To 1)
  For Each objCell In objRange

...und eines hatte ich vergessen zu erwähnen und zwar füge die Werte in die erste freie zelle in Tabelle1 in Spalte A ein.
Kannst du deinen Code so anpassen und den Fehler beheben?
Gruß Bernd
AW: VBA; nur verschiedene markierte Zellen kopieren
07.10.2017 18:54:19
Sepp
Hallo Bernd,
den Syntaxfehler kann ich nicht nachvollziehen!
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub copySelectedCells()
Dim objRange As Object, objCell As Object, objArea As Object, varOutput() As Variant, lngIndex As Long

With Sheets("Tabelle1")
  On Error Resume Next
  Set objRange = Intersect(Selection, .Range("B3:B7,D3:D7,F3:F7,H3:H7"))
  On Error GoTo 0
  
  If Not objRange Is Nothing Then
    Redim varOutput(1 To objRange.Cells.Count, 1 To 1)
    For Each objArea In objRange.Areas
      For Each objCell In objArea
        lngIndex = lngIndex + 1
        varOutput(lngIndex, 1) = objCell.Value
      Next
    Next
    .Cells(Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1, 1).Resize(lngIndex, 1) = varOutput
  End If
End With
Set objRange = Nothing
End Sub

Gruß Sepp

Anzeige
Sorry, falscher Code!
07.10.2017 19:01:10
Sepp
Hallo Bernd,
nimm diesen.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub copySelectedCells()
Dim objRange As Object, objCell As Object, varOutput() As Variant, lngIndex As Long

With Sheets("Tabelle1")
  On Error Resume Next
  Set objRange = Intersect(Selection, .Range("B3:B7,D3:D7,F3:F7,H3:H7"))
  On Error GoTo 0
  
  If Not objRange Is Nothing Then
    Redim varOutput(1 To objRange.Cells.Count, 1 To 1)
    For Each objCell In objRange
      lngIndex = lngIndex + 1
      varOutput(lngIndex, 1) = objCell.Value
    Next
    .Cells(Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1, 1).Resize(lngIndex, 1) = varOutput
  End If
End With
Set objRange = Nothing
End Sub

Gruß Sepp

Anzeige
AW: Sorry, falscher Code!
07.10.2017 19:20:35
Bernd
Hallo Sepp,
der neue Code hat wieder Syntaxfehler und zwar folgende fettmarkierten Zeilen werden im VBE rot dargestellt..
  On Error Resume Next
  Set objRange = Intersect(Selection, .Range("B3:B7,D3:D7,F3:F7,H3:H7"))
  On Error GoTo 0
  
  If Not objRange Is Nothing Then
    Redim varOutput(1 To objRange.Cells.Count, 1 To 1)
    For Each objCell In objRange
      lngIndex = lngIndex + 1
      varOutput(lngIndex, 1) = objCell.Value
    Next
    .Cells(Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1, 1).Resize(lngIndex, 1)  _
= varOutput
  End If

Ich weiß nicht weiter.
Gruß Bernd
Anzeige
Sorry, falscher Code!
07.10.2017 19:28:30
Sepp
Hallo Bernd,
wo hast du den Code eingefügt?
Zeig mal den gesamten eingefügten Code.
Welche XL-Version verwendest du?
Gruß Sepp

AW: Sorry, falscher Code!
07.10.2017 19:43:33
Bernd
Hallo Sepp,
Code in Modul eingefügt
Sub copySelectedCells()
Dim objRange As Object, objCell As Object, varOutput() As Variant, lngIndex As Long
With Sheets("Tabelle1")
  On Error Resume Next
  Set objRange = Intersect(Selection, .Range("B3:B7,D3:D7,F3:F7,H3:H7"))
  On Error GoTo 0
  If Not objRange Is Nothing Then
    Redim varOutput(1 To objRange.Cells.Count, 1 To 1)
    For Each objCell In objRange
      lngIndex = lngIndex + 1
      varOutput(lngIndex, 1) = objCell.Value
    Next
    .Cells(Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1, 1).Resize(lngIndex, 1)  _
= varOutput
  End If
End With
Set objRange = Nothing
End Sub
Gruß Bernd
Anzeige
XL-Version ? o.T
07.10.2017 19:46:03
Sepp
Gruß Sepp

AW: XL-Version ? o.T
07.10.2017 19:53:49
Bernd
Hallo Sepp,
Sorry, vergessen
Office 2016 Pro 32bit
Windows 10 Pro 64bit
Gruß Bernd
Auswahl kopieren
07.10.2017 20:02:54
Sepp
Hallo Bernd,
https://www.herber.de/bbs/user/116793.xlsm
funktioniert tadellos! Nur die Tabellennamen waren bei dir anders/vertauscht.
Du willst aber schon, wie im Start-Post beschrieben, die ausgewählten Zellen kopieren, oder willst du die gefärbten Zellen kopiert haben?
Gruß Sepp

Anzeige
AW: Auswahl kopieren
07.10.2017 20:30:19
Bernd
Hallo Sepp,
wir "Pfeffersäcke" würden dazu sagen: "spitzenmäßig"
Hab vielen Dank für deine Bemühungen und bleib mir wohl gesonnen ;-)
Liebe Grüße aus Bremen und noch ein VBA-Code reiches Wochenende
Bernd

338 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige