860to864: Makro zum Kopieren benötigt...

Hallo und nachträglich noch einmal frohe Ostern an alle Excel-Verrückten ;-)
Jetzt aber zu meinem Problem, bei dem ich dringend Hilfe benötige...oder besser gesagt,
ich brauche ein Makro um Daten zu kopieren.
Um alles etwas einfacher zu gestalten, habe ich weiter unten eine Beispielsdatei hochgeladen.
Also...ich habe eine Datei in der es unter anderem ein Tabellenblatt auswertung und ein Tabellenblatt ergebnis gibt.
Im Tabellenblatt auswertung gibt es einige Spalten, die mit Formeln gefüllt sind und Daten aus anderen Tabellblättern holen.
Die Zellen mit den Daten beginnen ab Zeile 6.
Mit dem Makro möchte ich jetzt die Zellen (nicht nur die Daten sondern die Formeln) in das Tabellenblatt ergebnis kopieren und zwar sollen die Zellen wie folgt neu sortiert werden:
auswertung Spalte B nach ergebnis Spalte D
auswertung Spalte N nach ergebnis Spalte C
auswertung Spalte K nach ergebnis Spalte F
auswertung Spalte L nach ergebnis Spalte G
auswertung Spalte M nach ergebnis Spalte H
auswertung Spalte P nach ergebnis Spalte J
auswertung Spalte Q nach ergebnis Spalte K
auswertung Spalte R nach ergebnis Spalte L
auswertung Spalte S nach ergebnis Spalte M
So...bis hier ist es ja gar nicht schwer und ich hätte es selbst hinbekommen.
Jetzt kommt aber der Haken.
Es sollen nur die Zeilen in das Tabellenblatt ergebnis kopiert werden, wo im Tabellenblatt auswertung in den Feldern G oder H eine 1 steht...sind beide Zellen leer oder mit einer 0
gefüllt, dann soll die betreffende Zeile nicht kopiert werden.
Im Tabellenblatt ergebnis sollen die kopierten Zeilen ebenfalls ab Zeile 6 beginnen...aber ohne
Unterbrechung untereinander stehen. Entstehende Lücken durch nicht kopierte Zeilen darf es also nicht geben.
Wer kann mir so ein Makro basteln?
Ich stehe echt auf'm Schlauch und brauche Eure Hilfe....
Danke
tobi
https://www.herber.de/bbs/user/41668.xls

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Tobi,
das sollte es tun.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub kopieren()
Dim objAW As Worksheet, objEG As Worksheet
Dim lngR As Long, lngLast As Long, lngI As Long
Dim intC As Integer

On Error GoTo ErrExit
GMS

Set objAW = Sheets("auswertung")
Set objEG = Sheets("ergebnis")

With objAW

    lngLast = Application.Max(6, .Cells(Rows.Count, 2).End(xlUp).Row)
    lngI = 7
    objEG.Range("C7:M65536").ClearContents

    For lngR = 6 To lngLast
        If Application.Sum(.Range(.Cells(lngR, 7), .Cells(lngR, 8))) > 0 Then
            For intC = 2 To 19
                Select Case intC
                    Case 2
                        objEG.Cells(lngI, 4).Formula = .Cells(lngR, intC).Formula
                    Case 11
                        objEG.Cells(lngI, 6).Formula = .Cells(lngR, intC).Formula
                    Case 12
                        objEG.Cells(lngI, 7).Formula = .Cells(lngR, intC).Formula
                    Case 13
                        objEG.Cells(lngI, 8).Formula = .Cells(lngR, intC).Formula
                    Case 14
                        objEG.Cells(lngI, 3).Formula = .Cells(lngR, intC).Formula
                    Case 16
                        objEG.Cells(lngI, 10).Formula = .Cells(lngR, intC).Formula
                    Case 17
                        objEG.Cells(lngI, 11).Formula = .Cells(lngR, intC).Formula
                    Case 18
                        objEG.Cells(lngI, 12).Formula = .Cells(lngR, intC).Formula
                    Case 19
                        objEG.Cells(lngI, 13).Formula = .Cells(lngR, intC).Formula
                    Case Else
                End Select
            Next
            lngI = lngI + 1
        End If
    Next

End With

ErrExit:

Set objAW = Nothing
Set objEG = Nothing

GMS True

End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    .Calculation = IIf(Modus, -4105, -4135)
    .Cursor = IIf(Modus, -4143, 2)
End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

860to864: Makro zum Kopieren benötigt...

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread