Erweiterung der Kopier Range
08.04.2016 08:42:25
Paulinchen
Ich habe leider wiedermal ein Problem mit meinem VBA code und habe bisher bei google und hier im Forum noch keine Lösung gefunden die in meinem Code funktioniert, daher hoffe ich stark auf eure Hilfe :)
Hier erst einmal der Code, anschließend werde ich auf mei Problem eingehen:
Option Explicit
Public Sub CBD_Makro()
Dim Int_Blockanzahl As Integer
Dim Str_Datei As String
Dim Str_Registerkarte As String
Dim Rng_Suchbereich As Range
Dim Rng_Kopierbereich1 As Range
Dim Rng_Kopierbereich2 As Range
Dim Str_Block_ID As String
Dim i As Integer
Dim Test As String
Dim Zieldatei As Worksheet
'Definition der Variablen (Anzahlblöcke, Dateiname, Registerkartenname)
MsgBox ("Dieses Programm dient zur Übertragung der Überschriften")
Int_Blockanzahl = InputBox("Bitte tragen Sie die Anzahl aller Blöcker ein", "Ermittlung der _
Blockanzahl", "3")
Str_Datei = InputBox("Bitte tragen Sie den Namen der Datei ein, auf die Sie Zugreifen möchten", _
_
"Ermittlung der Datei", "Beispiel.xlsx")
Str_Registerkarte = InputBox("Bitte tragen Sie den Namen der Registerkarte ein, auf die Sie _
zugreifen möchten", "Ermittlung der Registerkartenvorlage", "Sheet1")
'Kopie der Blöcke in ein neues Tabellenblatt
For i = 1 To Int_Blockanzahl
Str_Block_ID = "Block " & i
Set Rng_Suchbereich = Workbooks(Str_Datei).Worksheets(Str_Registerkarte).Cells.Find( _
Str_Block_ID, lookat:=xlWhole)
If Rng_Suchbereich Is Nothing Then
MsgBox "Kein Ergebnis gefunden", , "Info zur Suche"
Else: 'MsgBox (Rng_Suchbereich.Row & " " & Rng_Suchbereich.Column)
Rng_Suchbereich.Copy
'MsgBox (Rng_Suchbereich.Value)
Test = "A" & i
'MsgBox (Test)
With Workbooks("Musterdatei.xlsm").Worksheets("Data Overview").Range(Test). _
_
PasteSpecial
End With
End If
Next i
End Sub
Also im Moment ist es so, dass der Code in einer Datei auf eine Registerkarte zugreift in der verschiedene "Blöcke" aufgebaut sind. Die Suchfunktion aus dem Code sucht nach den Block Überschriften (Block 1/Block 2/ Block 3 usw.)
Die Suche findet die gewünschten Zellen auch, allerdings möchte ich nun die gefundene Range von der einzelnen Zelle, auf einen größeren Zellbereich markieren. Die größere Range möchte ich gerne mit .end(xldown) und .end(xlright) definieren und anschließend kopieren.
hoffentlich hat einer von euch die richtige Lösung parat :)
grüße
paulinchen