werte automatisch in andere tabelle abschpeichern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo William!
Kopiere diesn Code in das Modul der Tabelle.
Beim ersten Export, wird die Datei "Backup.xls" im Verzeichnis der Mappe erstellt.
Die weiteren Daten werden untereinander angefügt.

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Enum XL_FILESTATUS
  XL_UNDEFINED = -1
  XL_CLOSED
  XL_OPEN
  XL_DONTEXIST
End Enum

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("B2:L2")) Is Nothing Then
  If Application.CountA(Range("B2:L2")) >= 11 Then
    If exportData(Range("B2:L2")) <> 0 Then
      If MsgBox("Die Daten wurden erfolgreich exportiert!" & Space(20) & _
        vbLf & vbLf & "Sollen die Daten gelöscht werden?", 292, "EXPORT") = 6 Then
        Range("B2:L2").ClearContents
      End If
    Else
      MsgBox "Fehler beim Export der Daten!" & Space(15), 64, "FEHLER"
    End If
  End If
End If

End Sub

Private Function exportData(ByRef rng As Range) As Long
Dim xlApp As Application
Dim objWb As Workbook
Dim objSh As Worksheet
Dim lngNext As Long
Dim strFile As String
Dim myStatus As XL_FILESTATUS

On Error GoTo ErrExit
GetMoreSpeed

strFile = ThisWorkbook.Path & "\Backup.xls"

If Dir(strFile) = "" Then

  Me.Copy
  With ActiveWorkbook
    .SaveAs strFile
    .VBProject.VBComponents(.Sheets(1).CodeName).CodeModule.DeleteLines 1, _
      .VBProject.VBComponents(.Sheets(1).CodeName).CodeModule.CountOfLines
    .Close True
  End With

  exportData = -1

  GoTo ErrExit
End If

myStatus = FileStatus(strFile)

If myStatus = XL_OPEN Then
  strFile = Dir(strFile)
  Set objWb = Workbooks(strFile)
  Set objSh = objWb.Sheets(1)
  lngNext = objSh.Cells(Rows.Count, 1).End(xlUp).Row + 1
  objSh.Cells(lngNext, 1) = Me.Range("A2")
  objSh.Range(objSh.Cells(lngNext, 2), objSh.Cells(lngNext, 12)).Value = rng.Value
  objWb.Save

  exportData = -1

ElseIf myStatus = XL_CLOSED Then

  Set xlApp = CreateObject("Excel.Application")

  With xlApp
    Set objWb = .Workbooks.Open(strFile)
    Set objSh = objWb.Sheets(1)
    lngNext = objSh.Cells(Rows.Count, 1).End(xlUp).Row + 1
    objSh.Cells(lngNext, 1) = Me.Range("A2")
    objSh.Range(objSh.Cells(lngNext, 2), objSh.Cells(lngNext, 12)).Value = rng.Value
    objWb.Close True
    .Quit
  End With

  exportData = -1

End If

ErrExit:
GetMoreSpeed 0
Set objSh = Nothing
Set objWb = Nothing
Set xlApp = Nothing

End Function

Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
Static lngCalc As Long

With Application
  If Modus = 1 Then
    lngCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = -4135
    .Cursor = xlWait
  Else
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = IIf(lngCalc > 0, lngCalc, -4105)
    .Cursor = xlDefault
  End If
End With

End Sub

Private Function FileStatus(xlFile As String) As XL_FILESTATUS

On Error Resume Next

Dim File%: File = FreeFile

Err.Clear

Open xlFile For Binary Access Read Lock Read As #File
Close #File

Select Case Err.Number
  Case 0: FileStatus = XL_CLOSED
  Case 70: FileStatus = XL_OPEN
  Case 76: FileStatus = XL_DONTEXIST
  Case Else: FileStatus = XL_UNDEFINED
End Select

End Function

Gruß Sepp

Hallo William!
Füge in dein Tabellenblatt einen CommandButton aus der Steuerelemente-Toolbox ein.
Ersetze dann den Code im Tabellenmodul durch den folgenden.

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Enum XL_FILESTATUS
  XL_UNDEFINED = -1
  XL_CLOSED
  XL_OPEN
  XL_DONTEXIST
End Enum

Private Sub CommandButton1_Click()
Dim intC As Integer

If MsgBox("Wollen Sie die Daten exportieren?" & Space(15), 36, "EXPORT") = 6 Then
  intC = Application.CountA(Range("B2:L2"))
  If intC = 0 Then
    MsgBox "Es sind keine Daten vorhanden!" & Space(15), 32, "ABBRUCH"
    Exit Sub
  ElseIf intC < 11 Then
    If MsgBox("Es sind nicht alle Datenfelder gefüllt!" & Space(15) & vbLf & vbLf & _
      "Export fortsetzen?", 36, "EXPORT") <> 6 Then Exit Sub
  End If

  If exportData(Range("B2:L2")) <> 0 Then
    If MsgBox("Die Daten wurden erfolgreich exportiert!" & Space(20) & _
      vbLf & vbLf & "Sollen die Daten gelöscht werden?", 292, "EXPORT") = 6 Then
      Range("B2:L2").ClearContents
    End If
  Else
    MsgBox "Fehler beim Export der Daten!" & Space(15), 64, "FEHLER"
  End If

End If

End Sub

Private Function exportData(ByRef rng As Range) As Long
Dim xlApp As Application
Dim objWb As Workbook
Dim objSh As Worksheet
Dim lngNext As Long
Dim strFile As String
Dim myStatus As XL_FILESTATUS

On Error GoTo ErrExit
GetMoreSpeed

strFile = ThisWorkbook.Path & "\Backup.xls"

If Dir(strFile) = "" Then

  Me.Copy
  With ActiveWorkbook
    .SaveAs strFile
    .Sheets(1).Shapes(1).Delete
    .VBProject.VBComponents(.Sheets(1).CodeName).CodeModule.DeleteLines 1, _
      .VBProject.VBComponents(.Sheets(1).CodeName).CodeModule.CountOfLines
    .Close True
  End With

  exportData = -1

  GoTo ErrExit
End If

myStatus = FileStatus(strFile)

If myStatus = XL_OPEN Then
  strFile = Dir(strFile)
  Set objWb = Workbooks(strFile)
  Set objSh = objWb.Sheets(1)
  lngNext = objSh.Cells(Rows.Count, 1).End(xlUp).Row + 1
  objSh.Cells(lngNext, 1) = Me.Range("A2")
  objSh.Range(objSh.Cells(lngNext, 2), objSh.Cells(lngNext, 12)).Value = rng.Value
  objWb.Save

  exportData = -1

ElseIf myStatus = XL_CLOSED Then

  Set xlApp = CreateObject("Excel.Application")

  With xlApp
    Set objWb = .Workbooks.Open(strFile)
    Set objSh = objWb.Sheets(1)
    lngNext = objSh.Cells(Rows.Count, 1).End(xlUp).Row + 1
    objSh.Cells(lngNext, 1) = Me.Range("A2")
    objSh.Range(objSh.Cells(lngNext, 2), objSh.Cells(lngNext, 12)).Value = rng.Value
    objWb.Close True
    .Quit
  End With

  exportData = -1

End If

ErrExit:
GetMoreSpeed 0
Set objSh = Nothing
Set objWb = Nothing
Set xlApp = Nothing

End Function

Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
Static lngCalc As Long

With Application
  If Modus = 1 Then
    lngCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = -4135
    .Cursor = xlWait
  Else
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = IIf(lngCalc > 0, lngCalc, -4105)
    .Cursor = xlDefault
  End If
End With

End Sub

Private Function FileStatus(xlFile As String) As XL_FILESTATUS

On Error Resume Next

Dim File%: File = FreeFile

Err.Clear

Open xlFile For Binary Access Read Lock Read As #File
Close #File

Select Case Err.Number
  Case 0: FileStatus = XL_CLOSED
  Case 70: FileStatus = XL_OPEN
  Case 76: FileStatus = XL_DONTEXIST
  Case Else: FileStatus = XL_UNDEFINED
End Select

End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

werte automatisch in andere tabelle abschpeichern

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

werte automatisch in andere tabelle abschpeichern

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread