Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Werte auslesen und in neue Tabelle schreiben | Herbers Excel-Forum


Betrifft: Werte auslesen und in neue Tabelle schreiben von: Dirk
Geschrieben am: 01.12.2009 15:51:05

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

  

Betrifft: AW: Werte auslesen und in neue Tabelle schreiben von: Josef Ehrensberger
Geschrieben am: 01.12.2009 17:42:17

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



Gruß Sepp



Beiträge aus den Excel-Beispielen zum Thema "Werte auslesen und in neue Tabelle schreiben"