AW: Makro um Zeilen mit gleichem Inhalt zu kopieren
15.10.2009 19:35:57
Josef
Hallo Christian,
das sollte es tun.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub copyNumbers()
Dim objSh As Worksheet
Dim lngStart As Long, lngEnd As Long, lngLast As Long, lngIndex As Long
On Error GoTo ErrExit
GMS
With Sheets("Tabelle2") 'Quelltabelle - Name anpassen!
lngLast = .Cells(Rows.Count, 1).End(xlUp).Row
lngIndex = .Index
lngStart = 1
Do
lngEnd = lngStart + Application.Max(lngStart, Application.CountIf(.Range("A:A"), .Cells(lngStart, 1))) - 1
If SheetExist(.Cells(lngStart, 1).Text, ThisWorkbook) Then
Set objSh = ThisWorkbook.Sheets(.Cells(lngStart, 1).Text)
objSh.Cells.Clear
lngIndex = objSh.Index
Else
Set objSh = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Sheets(lngIndex))
objSh.Name = .Cells(lngStart, 1).Text
lngIndex = lngIndex + 1
End If
.Range(.Cells(lngStart, 1), .Cells(lngEnd, 1)).EntireRow.Copy objSh.Cells(1, 1)
lngStart = lngEnd + 1
Loop While lngStart <= lngLast
.Activate
End With
ErrExit:
With Err
If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & "In Prozedur (copyNumbers) in Modul Modul1", _
vbExclamation, "Fehler in Modul1 / copyNumbers"
End With
GMS True
Set objSh = Nothing
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub
Gruß Sepp