Microsoft Excel

Herbers Excel/VBA-Archiv

Code vereinfachen


Betrifft: Code vereinfachen von: Guesa
Geschrieben am: 13.08.2018 12:48:26

Hallo Forum
Folgende Codeschnipsel habe ich mir zusammengebastelt und funktioniert sogar. Aber, ich müsste davon insgesamt 10 verschiedene Bereiche in Auswertung untereinander kopieren, und das müsste doch einfacher gehen. Ich bekomme es nicht hin das in einer Code-Anweisung aus der aktiven Zeile die Spalte A und E, F (F-I sind verbunden) und J kopiert werden (nur Werte) und anschließend in Auswertung Zeile 2 Spalte A - D eingefügt werden. Der nächste Bereich wäre dann Spalte A und K und L (L - O verbunden) kopieren und in Auswertung Zeile 2 in F - H eingefügt werden usw. Das wären die Einzelauswertungen. Nächstes Problem wäre dann, die 10 Bereiche die Variabel gefüllt sind am Ende der Tabelle z.B. ab Spalte AS untereinander zu Kopieren also Spalten A - D, F - H untereinander. Ich hoffe das ich das einigermaßen erklärt habe. Für Eure Hilfe schon mal ein Danke

Gruß, Guesa

Sub Auswertung1()
Application.ScreenUpdating = False

Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 1)).Copy
Sheets("Auswertung").Cells(Sheets("Auswertung").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1). _
PasteSpecial xlPasteValues
'--------------A nach Auswertung A
Range(Cells(ActiveCell.Row, 5), Cells(ActiveCell.Row, 5)).Copy
Sheets("Auswertung").Cells(Sheets("Auswertung").Cells(Rows.Count, 2).End(xlUp).Row + 1, 2). _
PasteSpecial xlPasteValues
'--------------E nach Auswertung B
Range(Cells(ActiveCell.Row, 6), Cells(ActiveCell.Row, 6)).Copy
Sheets("Auswertung").Cells(Sheets("Auswertung").Cells(Rows.Count, 3).End(xlUp).Row + 1, 3). _
PasteSpecial xlPasteValues
'--------------F nach Auswertung C
Range(Cells(ActiveCell.Row, 10), Cells(ActiveCell.Row, 10)).Copy
Sheets("Auswertung").Cells(Sheets("Auswertung").Cells(Rows.Count, 4).End(xlUp).Row + 1, 4). _
PasteSpecial xlPasteValues
'--------------J nach Auswertung D
Application.CutCopyMode = False
Range(Cells(ActiveCell.Row, 5), Cells(ActiveCell.Row, 5)).Interior.ColorIndex = 35
Range(Cells(ActiveCell.Row, 10), Cells(ActiveCell.Row, 10)).Interior.ColorIndex = 35
Application.ScreenUpdating = True
End Sub

  

Betrifft: AW: Code vereinfachen von: ChrisL
Geschrieben am: 13.08.2018 13:22:54

Hi

Zwei Varianten:

Sub Auswertung1()
Dim lZ As Long

Application.ScreenUpdating = False
With Worksheets("Auswertung")
    lZ = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    .Cells(lZ, 1) = Cells(ActiveCell.Row, 1)
    .Cells(lZ, 2) = Cells(ActiveCell.Row, 5)
    .Cells(lZ, 3) = Cells(ActiveCell.Row, 6)
    .Cells(lZ, 4) = Cells(ActiveCell.Row, 10)
End With

Cells(ActiveCell.Row, 5).Interior.ColorIndex = 35
Cells(ActiveCell.Row, 10).Interior.ColorIndex = 35
Application.ScreenUpdating = True
End Sub
Sub Auswertung2()
Dim lZ As Long, arrSpalten As Variant, i As Integer

arrSpalten = Array(1, 5, 6, 10) 'hier anpassen

Application.ScreenUpdating = False
With Worksheets("Auswertung")
    lZ = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    For i = LBound(arrSpalten) To UBound(arrSpalten)
        .Cells(lZ, i + 1) = Cells(ActiveCell.Row, arrSpalten(i))
    Next i
End With

Cells(ActiveCell.Row, 5).Interior.ColorIndex = 35
Cells(ActiveCell.Row, 10).Interior.ColorIndex = 35
Application.ScreenUpdating = True
End Sub
cu
Chris


  

Betrifft: AW: Code vereinfachen von: Guesa
Geschrieben am: 13.08.2018 14:06:57

Hallo ChrisL
Danke für die schnelle Antwort funktioniert, das hilft schon mal ein Stück weiter. Hättest du eventuell auch noch eine Lösung für mein zweites Problem?. Also Variable Bereiche untereinander zu kopieren in meinem Fall wäre das ja
A2 - D letzte Beschriebene in Spalte AS2 - AV2 darunter dann
F2 - H letzte beschriebene

Gruß, Guesa


  

Betrifft: AW: Code vereinfachen von: ChrisL
Geschrieben am: 13.08.2018 14:09:45

Hi

.Range(.Cells(lZ, "AS"), .Cells(lZ, "AV")) = .Range(Cells(ActiveCell.Row, "A"), Cells(ActiveCell.Row, "D")).Value

cu
Chris


  

Betrifft: AW: Code vereinfachen von: ChrisL
Geschrieben am: 13.08.2018 14:19:43

Mist... ein Punkt zuviel

.Range(.Cells(lZ, "AS"), .Cells(lZ, "AV")) = Range(Cells(ActiveCell.Row, "A"), Cells(ActiveCell.Row, "D")).Value


  

Betrifft: AW: Code weiter vereinfachen von: Daniel
Geschrieben am: 13.08.2018 14:31:21

noch einfacher:

.cells(IZ, "AS").Resize(, 4) = Cells(ActiveCell.Row, 1).Resize(, 4)

Gruß Daniel


  

Betrifft: AW: Code weiter vereinfachen von: ChrisL
Geschrieben am: 13.08.2018 17:53:23

Hi Daniel

Danke für den Hinweis. Resize vergesse ich gerne.

cu
Chris


  

Betrifft: AW: Code weiter vereinfachen von: Guesa
Geschrieben am: 14.08.2018 09:57:11

Hallo Chris und Daniel
Danke für Eure Rückmeldung
Sehr wahrscheinlich stelle ich mich da nicht so geschickt an. Bekomme die Fehlermeldung
"Unzulässiger oder nicht ausreichend definierter Verweis"
Aber ich seh gerade das die Dim IZ Anweisung da auch steht, als unwissender gehe ich jetzt mal davon aus das diese Zeile in den davorigen Code mit eingebunden ist. Ich möchte gerne das diese einzelnen Bereiche A-D, F-H und die da noch kommenden Bereiche mit einem eigenen Code untereinander kopiert werden, beim nächsten kopieren dieser gesamt Bereich wieder überschrieben wird, damit ich dann dort eine gesamt Auswertung vornehmen kann. Falls ich da jetzt Blödsinn erzählt haben sollte, nehmt es mir nicht übel, unwissend halt.
Danke für Eure Mühe

Gruß, Guesa



  

Betrifft: Bitte Beispieldatei owT. von: ChrisL
Geschrieben am: 14.08.2018 10:22:30

.


  

Betrifft: AW: Bitte Beispieldatei owT. von: Guesa
Geschrieben am: 14.08.2018 11:17:14

Hallo Chris
hier mal auf die schnelle eine Datei.

Gruß, Guesa

https://www.herber.de/bbs/user/123319.xlsm


  

Betrifft: AW: Bitte Beispieldatei owT. von: ChrisL
Geschrieben am: 14.08.2018 11:24:31

Hi

Sub t()
Dim lZ As Long

With ActiveSheet
    lZ = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range("A3:D" & lZ).Copy .Cells(Rows.Count, 15).End(xlUp).Offset(1, 0)
    
    lZ = .Cells(Rows.Count, 6).End(xlUp).Row
    .Range("F3:H" & lZ).Copy .Cells(Rows.Count, 15).End(xlUp).Offset(1, 0)
    
    lZ = .Cells(Rows.Count, 10).End(xlUp).Row
    .Range("J3:M" & lZ).Copy .Cells(Rows.Count, 15).End(xlUp).Offset(1, 0)
End With
End Sub
cu
Chris


  

Betrifft: AW: Bitte Beispieldatei owT. von: Guesa
Geschrieben am: 14.08.2018 11:27:31

Hi Chris

Shit habe ich vergessen, beim nächsten kopieren sollte die Gesamtauswertung wieder überschrieben werden.

Gruß, Guesa


  

Betrifft: AW: Bitte Beispieldatei owT. von: Guesa
Geschrieben am: 14.08.2018 11:34:53

Hi Chris

Wow bist du schnell, Danke dir recht herzlich für Deine Mühe

Gruß, Guesa


Beiträge aus dem Excel-Forum zum Thema "Code vereinfachen"