HERBERS Excel-Forum - das Archiv
Thema: Werte auslesen und in neue Tabelle schreiben | Herbers Excel-Forum
Werte auslesen und in neue Tabelle schreiben
Dirk
Hallo zusammen,
ich möchte gern aus einer Tabelle Zeilen auslesen, die Werte in einer bestimmten Spalte enthalten und diese Zeilen dann in einer neuen Tabelle abspeichern, dabei soll die Speicherung nach "Name_Zeitstempel" erfolgen.
Leider reichen meine Macrokenntnisse dafür nicht aus, hat jemand einen Ansatz?
Vielen Dank,
Dirk
AW: Werte auslesen und in neue Tabelle schreiben
Josef
Hallo Dirk,
deine Angaben sind ein wenig Mager.
Die Tabelle beginnt in A1 und es handelt sich um eine integre Liste. Kopiert werden alle Zeilen die in
einer im Code vorgegebenen Spalte einen Wert stehen haben.
Code in ein allgemeines Modul kopieren, Code anpassen (siehe Kommentare) und ausprobieren.
' **********************************************************************
' 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
' 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
Gruß Sepp
Excel-Beispiele