Daten auslesen und in Tabellen direkt einfügen

Die Aufgabenstellung: Daten aus einer Ursprungstabelle sollen automatisch auf verschiedene Zieltabellen verteilt werden. Damit dies funktioniert muss lediglich einmal die Zuordnung geschaffen werden, dann klappt es aber problemlos wie das nachfolgende Beispiel zeigt (einfach als Makro als allgemeines Modul in Excel einfügen und gemäß der Kommentare anpassen).

‘ **********************************************************************
‘ Modul: Modul1 Typ: Allgemeines Modul
‘ **********************************************************************

Option Explicit

Sub copyToNewSheet()
Dim objWb As Workbook, rng As Range
Dim strPath As String, strUser As String, strDateTime As String

Const lngColumn As Long = 6 ‘Spalte in der die Werte gesucht werden – Anpassen!

On Error GoTo ErrExit
GMS

strPath = “E:Temp” ‘Speicherpfad – Anpassen!

If Right(strPath, 1) <> “” Then strPath = strPath & “”

strUser = Environ(“USERNAME”)
strDateTime = Format(Now, “_yyyymmdd-hhMMss”)

With Sheets(“Tabelle1″) ‘Tabelle mit der Liste – Anpassen!
If .AutoFilterMode Then .AutoFilterMode = False
With .Range(“A1″).CurrentRegion
.AutoFilter Field:=lngColumn, Criteria1:=”<>”
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo ErrExit
.AutoFilter
End With
End With

If Not rng Is Nothing Then
Set objWb = Application.Workbooks.Add(xlWBATWorksheet)
rng.Copy objWb.Sheets(1).Range(“A1″)
objWb.Sheets(1).Name = rng.Parent.Name
objWb.SaveAs strPath & strUser & strDateTime & “.xls”
objWb.Close
End If

ErrExit:
With Err
If .Number <> 0 Then MsgBox “Fehler ” & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & “In Prozedur (copyToNewSheet) in Modul Modul1″, _
vbExclamation, “Fehler in Modul1 / copyToNewSheet”
End With

GMS True

Set rng = Nothing
Set objWb = Nothing
End Sub

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