Ich habe eine sehr große Excel-Datei und will dabei folgende Teile markieren und kopieren
--> Immer im Abstand von 2
Range("B2,B6:B11,D2,D6:D11,F2,F6:F11").Select
Kann mir bitte jemand helfen wie ich daraus ein VBA Makro schreibe, dass bis einschließlich Spalte UO geht.
Würde mir sehr helfen.
Vielen Dank im Voraus.
17.02.2018, 22:31 (Dieser Beitrag wurde zuletzt bearbeitet: 17.02.2018, 22:37 von DbSam.)
Hallo Uwe,
(17.02.2018, 19:25)Waldmensch15 schrieb: Ich habe eine sehr große Excel-Datei und will dabei folgende Teile markieren und kopieren
--> Immer im Abstand von 2
(17.02.2018, 19:25)Kuwer schrieb: ... ist für mich verständlich beschrieben.
Also für mich ist das nicht verständlich genug beschrieben.
Die Markiererei ist beschrieben, gut. Aber wohin soll das 'Zeugs' kopiert werden?
Aus dem Screenshot kann man sich das auch nicht entnehmen. Jedenfalls ich nicht. Kann ja auch an mir liegen ...
Wie auch immer, ich habe da mal was für den Anfang gebastelt.
Das 'Problem' ist die Größe der Mehrfachselektion, deshalb in einzelne Bereiche gesplittet und diese dann zusammengesetzt.
Der besseren Anpassbarkeit wegen, haben ich die benötigten Namen am Anfang aufgeführt. Diese halt bei Bedarf anpassen ...
Vielleicht gibt es auch einen besseren Weg, um solch eine Menge von verschiedenen Zellbereichen zu selektieren. Ich kenne im Moment keinen besseren.
Code:
Sub MonsterRange()
On Error GoTo Er
Dim s As String, BName As String, TabName As String, i As Long
TabName = "Tabelle1"
BName = "Test"
With ActiveWorkbook
.Sheets(TabName).Activate
CreateName BName & "_01", TabName, 2, 100
CreateName BName & "_02", TabName, 102, 200
CreateName BName & "_03", TabName, 202, 300
CreateName BName & "_04", TabName, 302, 400
CreateName BName & "_05", TabName, 402, 500
CreateName BName & "_06", TabName, 502, 561
For i = 1 To 6
s = s & ActiveWorkbook.Name & "!" & BName & "_0" & i & ","
Next i
DeleteName BName
.Names.Add Name:=BName, RefersToR1C1:="=" & Left(s, Len(s) - 1)
Application.Goto Reference:=BName
Selection.Copy
'So, jetzt wird das 'Zeugs' irgendwohin kopiert.
'Ist halt nicht genau definiert:
.Sheets(TabName).Range("A14").Select
.Sheets(TabName).Paste
Application.CutCopyMode = False
.Sheets(TabName).Range("B2").Select
End With
Ex:
Exit Sub
Er:
MsgBox Err.Description
End Sub
Sub CreateName(ByVal BName As String, ByVal TabName As String, ByVal iFrom As Integer, ByVal iTo As Integer)
On Error GoTo Er
Dim i As Integer, s As String
DeleteName BName
For i = iFrom To iTo Step 2
s = s & TabName & "!R2C" & i & "," & TabName & "!R6C" & i & ":R11C" & i & ","
Next i
ActiveWorkbook.Names.Add Name:=BName, RefersToR1C1:="=" & Left(s, Len(s) - 1)
Ex:
Exit Sub
Er:
MsgBox Err.Description
End Sub
Sub DeleteName(ByVal BName As String)
Dim bb As Name
For Each bb In ActiveWorkbook.Names
If bb.Name = BName Then bb.Delete
Next bb
End Sub
Nun harren wir der Bemerkungen die da kommen werden ...
Hoffentlich sind da auch Erklärungen mit dabei. ;)
sorry, ich habe mir Deinen Code jetzt nicht näher angesehen.
Das ist meine Antwort auf Deine gestellte Frage, Orang-Utan Nr. 15: :19:
Sub BereichMarkierenUndKopieren()
Dim rngB As Range, rngZ As Range
Dim i As Long
Set rngZ = Range("2:2,6:11")
Set rngB = Application.Intersect(rngZ, Columns(2))
For i = 4 To 561 Step 2
Set rngB = Application.Union(rngB, Application.Intersect(rngZ, Columns(i)))
Next i
rngB.Select
rngB.Copy
End Sub