Nur bestimmte Zellen kopieren
11.02.2004 08:56:20
Markus
Ich habe da ein Problem mit einer VBA-Prozedur.
Ich habe ein Tabellenblatt mit mehreren Spalten. In den ersten 6 stehen Angaben wie Namen u.s.w.
Dann kommt jeweils eine Spalte mit Stunden und dann mit Kosten für alle Monate des Jahres.
Die Tabelle wollte ich nun so gestalten das nicht alle Werte nebeneinander stehen sondern untereinander.
Sprich immer die ersten 6 Spalten (mit den Namen) und dann immer untereinander die Monate.
Das hab ich soweit auch geschafft. Allerdings Habe ich eine Auswahl getroffen das nur die Zeilen kopiert
werden die auch eine bestimmte Anforderung erfüllen.
Nun mein Problem:
Wenn ich meine Prozedur wie oben ausführe dann schreibt er mit wie ich es dem Rechner gesagt
habe die verglichenen Zelle auch wieder in die entsprechende Zelle auf dem neuen Tabellenblatt.
Die wollte ich dann wieder löschen. Das tut er auch allerdings braucht er dafür echt verdammt lang.
1. Kann man das beschleunigen?
oder 2. Kann man meinen Code so umändern das er die Leerzeilen nicht druckt?
Hier mein Code:
Sub Konverter()
Dim i As Long, lar As Long
Dim ActiveSheets As Worksheet
Dim x As Integer
Dim rg As Range
Dim ws1 As Worksheet
On Error GoTo Err_Konverter
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Gesamtübersicht"
Sheets("Std-Erfassung").Select
lar = Cells(Rows.Count, 3).End(xlUp).Row
For i = 1 To lar
If Not IsEmpty(Sheets("Std-Erfassung").Cells(i, 6).Value) And Not IsEmpty(Sheets("Std-Erfassung").Cells(i, 7).Value) Or Not IsEmpty(Sheets("Std-Erfassung").Cells(i, 8).Value) Then
'Januar
Sheets("Gesamtübersicht").Cells(i, 1).Value = Sheets("Std-Erfassung").Cells(i, 1).Value
Sheets("Gesamtübersicht").Cells(i, 2).Value = Sheets("Std-Erfassung").Cells(i, 2).Value
Sheets("Gesamtübersicht").Cells(i, 3).Value = Sheets("Std-Erfassung").Cells(i, 3).Value
Sheets("Gesamtübersicht").Cells(i, 4).Value = Sheets("Std-Erfassung").Cells(i, 4).Value
Sheets("Gesamtübersicht").Cells(i, 5).Value = Sheets("Std-Erfassung").Cells(i, 5).Value
Sheets("Gesamtübersicht").Cells(i, 6).Value = Sheets("Std-Erfassung").Cells(i, 6).Value
Sheets("Gesamtübersicht").Cells(i, 7).Value = Sheets("Std-Erfassung").Cells(i, 7).Value
Sheets("Gesamtübersicht").Cells(i, 8).Value = Sheets("Std-Erfassung").Cells(i, 8).Value
End If
Next i
Sheets("Gesamtübersicht").Select
Set ws1 = Worksheets("Gesamtübersicht")
Set rg = ws1.Range("A6980")
For x = 1 To rg.End(xlUp).Row - 1
If IsEmpty(Cells(x, 1).Value) And IsEmpty(Cells(x, 2).Value) Then
Rows(x & ":" & x).Delete Shift:=xlUp
x = x - 1
End If
Next x
Exit_Konverter:
Exit Sub
Err_Konverter:
MsgBox Err.Description
Resume Exit_Konverter
End Sub