AW: Daten übertragen; Gesperrte Zelle ignorieren
16.03.2009 20:57:27
Josef
Hallo Dietmar,
der angepasste Code sollte es tun.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub DatenUebertragen()
Dim strFile As String, strNewName As String
Dim objWB As Workbook, objWS As Worksheet, objTarget As Worksheet
Dim rng As Range, rngF As Range, rngC As Range
Dim blnOpen As Boolean
Dim lngRow As Long, lngLast As Long, lngN As Long
Dim varResult As Variant
On Error GoTo ErrExit
GMS
strFile = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm")
If strFile = "Falsch" Or strFile = ThisWorkbook.FullName Then GoTo ErrExit
blnOpen = IsOpen(strFile)
If blnOpen Then
Set objWB = Workbooks(Mid(strFile, InStrRev(strFile, "\") + 1))
Else
Set objWB = Workbooks.Open(strFile)
End If
Set objTarget = objWB.Sheets("Tabelle1")
For Each objWS In ThisWorkbook.Worksheets
With objWS
Select Case .Name
Case "PersonalDaten"
objTarget.Cells(6, 2) = .Cells(2, 2)
objTarget.Cells(7, 2) = .Cells(3, 2)
For lngRow = 4 To 7
objTarget.Cells(lngRow + 6, 2) = .Cells(lngRow, 2)
Next
Case "BelegeMarken"
lngN = 2
For lngRow = 66 To 71
objTarget.Cells(lngRow, 3) = .Cells(lngN, 2)
objTarget.Cells(lngRow, 4) = .Cells(lngN + 3, 2)
lngN = lngN + 1
If lngN = 5 Then lngN = 8
Next
Case "Gewicht"
For lngRow = 2 To 6
objTarget.Cells(lngRow + 189, IIf(lngRow < 5, 3, 2)) = .Cells(lngRow, 2)
Next
Case "PV"
Set rng = .Range("D2:D" & .Cells(Rows.Count, 4).End(xlUp).Row)
Set rngF = objTarget.Range("A76:A183")
For Each rngC In rng
If rngC <> "" And IsNumeric(rngC) Then
varResult = Application.Match(rngC.Offset(0, -3), rngF, 0)
If IsNumeric(varResult) Then
objTarget.Cells(varResult + 75, 4) = rngC
End If
End If
Next
Case "TN"
Set rng = .Range("C2:C" & .Cells(Rows.Count, 3).End(xlUp).Row)
Set rngF = objTarget.Range("A16:A62")
For Each rngC In rng
If rngC <> "" And IsNumeric(rngC) Then
varResult = Application.Match(rngC.Offset(0, -2), rngF, 0)
If IsNumeric(varResult) Then
objTarget.Cells(varResult + 15, 7) = rngC
End If
End If
Next
Case Else
End Select
End With
Next
Application.Calculate
strNewName = "Etally" & objTarget.Cells(9, 2).Text & Mid(objWB.Name, InStrRev(objWB.Name, "."))
'strNewName = objTarget.Cells(9, 2).Text & Mid(objWB.Name, InStrRev(objWB.Name, ".")) 'ohne des Namenszusatz Etally
'objWB.SaveAs objWB.Path & "\" & strNewName 'Speichern im gleichen Ordner wie die Original-Zieldatei
objWB.SaveAs "C:\MLC2008" & "\" & strNewName 'Speichern unter vorgegebenem Pfad
'strSaveAsName = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xls; *.xlsx; *.xlsm)," & _
' "*.xls; *.xlsx; *xlsm", InitialFileName:=strNewName, Title:="Überprüfen sie den Dateinamen/Pfad!") 'Speicherpfad abfragen
objWB.Close
MsgBox "Die Datei " & strNewName & " wurde erfolgreich gespeichert.", vbInformation, "MLC2008 Meeting-Leader-Calculator"
ErrExit:
With Err
If .Number = 1004 And .Description Like "*schreibgeschützt*" Then
.Clear
Resume Next
End If
If .Number <> 0 Then MsgBox .Number & vbLf & vbLf & .Description, vbExclamation, "Fehler"
End With
GMS True
Set objWB = Nothing
Set objWS = Nothing
Set rng = Nothing
Set rngF = Nothing
Set rngC = Nothing
End Sub
Private 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
Private Function IsOpen(ByVal WBFullName As String) As Boolean
Dim objWB As Workbook
For Each objWB In Application.Workbooks
If objWB.FullName = WBFullName Then
IsOpen = True
Exit For
End If
Next
End Function
Gruß Sepp