Makro erstellen

Bild

Betrifft: Makro erstellen
von: Tobias Bode
Geschrieben am: 09.06.2015 20:23:53

Hallo,
ich bin mit der Programmierung von Makros noch sehr unerfahren, muss dies aber für eine Arbeit nun hinbekommen.
Ich möchte in meiner Datei die Daten aus einer Registerkarte in eine andere kopieren. Ist dies erfolgt sollen in der ersten Registerkarte wieder alle eingegebenen Daten gelöscht werden. Habe ich nun neue Daten eingegeben, so sollen diese ebenfalls in die zweite Registerkarte kopiert werden, jedoch rechts daneben.
Ich habe bei jetzt ein Makro aufzeichnen können, dass all dies macht, nur werden dabei die Daten kopiert und danach Spalten links eingefügt. Dort werden dann die nächsten Werte gespeichert usw.
Ich hoffe mir kann da jemand helfen.
Hier mein Code, keine Ahnung ob der hilfreich ist:

Sub Werte_zur_Scoreübersicht()
'
' Werte_zur_Scoreübersicht Makro
'
'
    Range("B1:B10").Select
    Selection.Copy
    Sheets("Scoreübersicht").Select
    Range("D1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("D5").Select
    Application.CutCopyMode = False
    Selection.Style = "Currency"
    Range("D10").Select
    Selection.Style = "Currency"
    Range("D1:D4").Select
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Sheets("Portfoliobewertung").Select
    Range("D9").Select
    Selection.Copy
    Sheets("Scoreübersicht").Select
    Range("D15").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Portfoliobewertung").Select
    Range("K15:K112").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Scoreübersicht").Select
    Range("D18").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("D18:D115,D15").Select
    Range("D15").Activate
    Application.CutCopyMode = False
    Selection.Style = "Percent"
    Selection.NumberFormat = "0.0%"
    Selection.NumberFormat = "0.00%"
    Sheets("Portfoliobewertung").Select
    ActiveWindow.ScrollRow = 91
    ActiveWindow.ScrollRow = 82
    ActiveWindow.ScrollRow = 50
    ActiveWindow.ScrollRow = 20
    ActiveWindow.ScrollRow = 15
    Range("H15:H112").Select
    Selection.Copy
    Sheets("Scoreübersicht").Select
    Range("E18").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("D:E").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.ColumnWidth = 20
    Range("D1:E115").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("F13:G13").Select
    Selection.Copy
    Range("D13").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheets("Portfoliobewertung").Select
    Range("K109:K112,K102:K106,K97:K99").Select
    Range("K97").Activate
    ActiveWindow.SmallScroll Down:=-9
    Range("K109:K112,K102:K106,K97:K99,K90:K92").Select
    Range("K90").Activate
    ActiveWindow.SmallScroll Down:=-3
    Range("K109:K112,K102:K106,K97:K99,K90:K92,K82:K87").Select
    Range("K82").Activate
    ActiveWindow.SmallScroll Down:=-12
    Range("K109:K112,K102:K106,K97:K99,K90:K92,K82:K87,K76:K79").Select
    Range("K76").Activate
    ActiveWindow.SmallScroll Down:=-12
    Range("K109:K112,K102:K106,K97:K99,K90:K92,K82:K87,K76:K79,K67:K69,K59:K64"). _
        Select
    Range("K59").Activate
    ActiveWindow.SmallScroll Down:=-12
    Range( _
        "K109:K112,K102:K106,K97:K99,K90:K92,K82:K87,K76:K79,K67:K69,K59:K64,K52:K56"). _
        Select
    Range("K52").Activate
    ActiveWindow.SmallScroll Down:=-9
    Range( _
        "K109:K112,K102:K106,K97:K99,K90:K92,K82:K87,K76:K79,K67:K69,K59:K64,K52:K56,K42:K47" _
        ).Select
    Range("K42").Activate
    ActiveWindow.SmallScroll Down:=-9
    Range( _
        "K109:K112,K102:K106,K97:K99,K90:K92,K82:K87,K76:K79,K67:K69,K59:K64,K52:K56,K42:K47, _
K38:K39,K33:K35" _
        ).Select
    Range("K33").Activate
    ActiveWindow.SmallScroll Down:=-12
    Range( _
        "K109:K112,K102:K106,K97:K99,K90:K92,K82:K87,K76:K79,K67:K69,K59:K64,K52:K56,K42:K47, _
K38:K39,K33:K35,K27:K30,K20:K24,B1" _
        ).Select
    Range("B1").Activate
    Selection.ClearContents
End Sub

Bild

Betrifft: AW: Makro erstellen
von: fcs
Geschrieben am: 10.06.2015 07:36:39
Hallo Tobias,
ich hab dein Makro mal so umgestellt, dass die nächste Einfügespalte rechts ermittelt wird und dann die Daten entsprechend kopiert werden.
Das hin- und herschalten zwschen den Blättern und die Select-Anweisungen sind nicht erforderlich. Ma kann die jeweiligen Zellbereiche auch direkt ansprechen und die gewünschte Aktion ausführen.
Der Makro-Rekorder zeichnet leider diesen etwas umständlicheren Code auf.
Gruß
Franz

Sub Werte_zur_Scoreübersicht()
'
' Werte_zur_Scoreübersicht Makro
'
    Dim wksScore As Worksheet
    Dim wksBewert As Worksheet
    Dim Spa As Long
'
    
    Set wksScore = ActiveWorkbook.Sheets("Scoreübersicht")
    Set wksBewert = ActiveWorkbook.Sheets("Portfoliobewertung")
    
    
    Application.ScreenUpdating = False
    With wksScore
'        .Select
        'nächste Einfüge-Spalte ermitteln
        Spa = .Cells(1, .Columns.Count).End(xlToLeft).Column
        If Spa < 4 Then Spa = 4 Else Spa = Spa + 2
        
        wksBewert.Range("B1:B10").Copy
        
    
        .Cells(1, Spa).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
            
        .Cells(5, Spa).Style = "Currency"
        .Cells(10, Spa).Style = "Currency"
        
        With .Range(.Cells(1, Spa), .Cells(4, Spa))
            .HorizontalAlignment = xlRight
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
    
        wksBewert.Range("D9").Copy
    
        .Cells(15, Spa).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        
        wksBewert.Range("K15:K112").Copy
    
        .Cells(18, Spa).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
            
        With Application.Union(.Range(.Cells(18, Spa), .Cells(115, Spa)), .Cells(15, Spa))
            .Style = "Percent"
            .NumberFormat = "0.00%"
        End With
        
        wksBewert.Range("H15:H112").Copy
        
        .Cells(18, Spa + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        
        With .Range(.Cells(1, Spa), .Cells(115, Spa + 1))
            .EntireColumn.ColumnWidth = 20
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
        End With
        
'###???? was soll mit den folgenden Zeilen noch erreicht werden?
'        Range("F13:G13").Select
'        Selection.Copy
'        Range("D13").Select
'        ActiveSheet.Paste
'        Application.CutCopyMode = False
    End With
    
    With wksBewert
        .Select
        .Range("K109:K112,K102:K106,K97:K99,K90:K92,K82:K87,K76:K79,K67:K69,K59:K64,K52:K56," _
            & "K42:K47,K38:K39,K33:K35,K27:K30,K20:K24,B1").ClearContents
        Range("B1").Select
    End With
    Application.ScreenUpdating = True
End Sub


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Makro erstellen"