AW: VBA-Makro zum Datenübertrag zwischen Excel-Sheets
30.06.2009 22:08:33
Josef
Hallo Thomas,
erstelle in der Datei zwei Module mit den Namen "basData" und "basAuxiliary" und kopiere den Code in die entsprechenden Module, auch in das Modul "DieseArbeitsmappe" den richtigen Codeteil kopieren.
Im Modul "basData" musst du den Pfad zur Gesamtdatei anpassen.
Datei speichern, schliessen und wieder öffnen, dann findest du im Zellkontextmenü einen neuen Menüpunkt "Daten übertragen ...".
' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Workbook_Activate()
addButton
End Sub
Private Sub Workbook_Deactivate()
deleteButton
End Sub
' **********************************************************************
' Modul: basData Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
'### ### Pfad und Name der "Gesamtdatei" - Anpassen! ### ###
Private Const cstrTargetFileName As String = "E:\Temp\Gesamtdatei.xls"
'### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
'Daten auslesen und übertragen
Private Sub sendData()
Dim objWS As Worksheet
Dim objTargetWB As Workbook
Dim rngTarget As Range
Dim lngRow As Long
On Error GoTo ErrExit
GMS
If FileStatus(cstrTargetFileName) = XL_CLOSED Then
Set objTargetWB = Workbooks.Open(cstrTargetFileName)
If SheetExist("Frequenz fortlaufend", objTargetWB.Name) Then
If SheetExist(CStr(DINKwoche(Date) - 1) & ". KW") Then
lngRow = Application.Max(objTargetWB.Sheets("Frequenz fortlaufend").Cells(Rows.Count, 1).End(xlUp).Row + 1, 2)
Set rngTarget = objTargetWB.Sheets("Frequenz fortlaufend").Cells(lngRow, 1)
Set objWS = ThisWorkbook.Sheets(CStr(DINKwoche(Date) - 1) & ". KW")
With objWS
.Range("A2:J" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy rngTarget
End With
objTargetWB.Close True
Else
MsgBox "Kein Tabellenblatt [" & CStr(DINKwoche(Date) - 1) & ". KW] gefunden!", _
vbInformation, "Hinweis"
End If
Else
MsgBox "In der Datei [" & objTargetWB.Name & "] wurde kein Tabellenblatt" & vbLf & vbLf & _
"[Frequenz fortlaufend] gefunden!", vbInformation, "Hinweis"
End If
Else
MsgBox "Die Datei [" & cstrTargetFileName & "] ist zur Zeit geöffnet!" & vbLf & vbLf & _
"Bitte versuchen Sie es später!", vbInformation, "Hinweis"
End If
ErrExit:
With Err
If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & "In Prozedur (sendData) in Modul basData", _
vbExclamation, "Fehler in basData / sendData"
End With
On Error Resume Next
objTargetWB.Close False
On Error GoTo 0
GMS True
Set objWS = Nothing
Set rngTarget = Nothing
Set objTargetWB = Nothing
End Sub
' **********************************************************************
' Modul: basAuxiliary Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Option Private Module
Public Enum XL_FILESTATUS
XL_UNDEFINED = -1
XL_CLOSED
XL_OPEN
XL_DONTEXIST
End Enum
'Hilfsfunktionen
Public Function FileStatus(xlFile As String) As XL_FILESTATUS
On Error Resume Next
Dim File%: File = FreeFile
Err.Clear
Open xlFile For Input 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
Err.Clear
End Function
Public Function DINKwoche(ByVal Datum As Date) As Integer
Dim tmp As Date
tmp = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
DINKwoche = ((Datum - tmp - 3 + (Weekday(tmp) + 1) Mod 7)) \ 7 + 1
End Function
Public Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).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
'Zellkontextmenü
Public Sub addButton()
Dim objBtn As CommandBarButton
deleteButton
Set objBtn = Application.CommandBars("Cell").Controls.Add(msoControlButton)
With objBtn
.Style = msoButtonAutomatic
.Caption = "Daten Übertragen - KW " & Format(DINKwoche(Date) - 1, "00")
.BeginGroup = True
.OnAction = "SendData"
End With
Set objBtn = Nothing
End Sub
Public Sub deleteButton()
On Error Resume Next
Application.CommandBars("Cell").Controls("Daten Übertragen - KW " & Format(DINKwoche(Date) - 1, "00")).Delete
On Error GoTo 0
End Sub
Gruß Sepp