AW: vielleicht geht es so.
25.10.2009 12:34:57
Dietmar
Hallo Tino,
geht leider nicht. Die Prüfroutine kommt zu spät. Habe Dir mal den ganzen Code beigefügt.
Schaust du mal drüber.
Danke
Gruß
Dietmar aus Aachen
Option Explicit
Sub TEntwicklungUebertrag()
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
'>>>>>>>>>> Berechnung auf automatisch stellen
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
' >>>>>>>>>> Tabelle aktivieren
'Set objTarget = objWB.Sheets(1) 'stattdessen soll die Sheetnummer nun gezielt aufgerufen werden,
' je nachdem, was in Zelle R22 der Eingssseite notiert ist.
'>>>NEU am 25.10.2009 von Tino (bereits angepasst
With ThisWorkbook.Sheets("Eingangsseite")
If IsNumeric(.Range("R22")) And .Range("R22") "" Then
Set objTarget = objWB.Sheets(.Range("A2"))
Else
Set objTarget = objWB.Sheets(1)
End If
End With
'>>> Ende NEU am 25.10.2009
For Each objWS In ThisWorkbook.Worksheets
With objWS
Select Case .Name
' >>>>>>>>>> Protokolldaten auslesen
Case "Protokoll"
'#################
'Die 1 in Spalte C des Zieles eintragen
Set rng = .Range("C2:C" & .Cells(Rows.Count, 2).End(xlUp).Row) 'Auslesen der KW in Quelle
Set rngF = objTarget.Range("B2:B100") 'Prüfung der KW-Übereinstimmung in der Quelle
For Each rngC In rng
If rngC "" Then
varResult = Application.Match(rngC.Offset(0, -1), rngF, 0) 'bei D muss offset -2 sein um auf Prüfspalte B zu kommen
If IsNumeric(varResult) Then
objTarget.Cells(varResult + 1, 3) = rngC.Value '1 Zeilen weiter als D2 s.o. = D3 im Ziel, 4 für Spalte = D gezählt ab B
End If
End If
Next
'#################
'TN
Set rng = .Range("D2:D" & .Cells(Rows.Count, 2).End(xlUp).Row) 'Auslesen der KW in Quelle
Set rngF = objTarget.Range("B2:B100") 'Prüfung der KW-Übereinstimmung in der Quelle
For Each rngC In rng
If rngC "" Then
varResult = Application.Match(rngC.Offset(0, -2), rngF, 0) 'bei D muss offset -2 sein um auf Prüfspalte B zu kommen
If IsNumeric(varResult) Then
objTarget.Cells(varResult + 1, 4) = rngC.Value '1 Zeilen weiter als D2 s.o. = D3 im Ziel, 4 für Spalte = D gezählt ab B
End If
End If
Next
'################
'NA
Set rng = .Range("F2:F" & .Cells(Rows.Count, 2).End(xlUp).Row)
Set rngF = objTarget.Range("B2:B100")
For Each rngC In rng
If rngC "" Then
varResult = Application.Match(rngC.Offset(0, -4), rngF, 0) 'Die Prüfspalte im Ziel von F nach B = -4
If IsNumeric(varResult) Then
objTarget.Cells(varResult + 1, 6) = rngC.Value '1 Zeilen weiter als C2 s.o = C3, 5 für Spalte = F
End If
End If
Next
'#################
'WA
Set rng = .Range("G2:G" & .Cells(Rows.Count, 2).End(xlUp).Row)
Set rngF = objTarget.Range("B2:B100")
For Each rngC In rng
If rngC "" Then
varResult = Application.Match(rngC.Offset(0, -5), rngF, 0)
If IsNumeric(varResult) Then
objTarget.Cells(varResult + 1, 7) = rngC.Value
End If
End If
Next
'#################
'MPP-VK
Set rng = .Range("M2:M" & .Cells(Rows.Count, 2).End(xlUp).Row)
Set rngF = objTarget.Range("B2:B100")
For Each rngC In rng
If rngC "" Then
varResult = Application.Match(rngC.Offset(0, -11), rngF, 0)
If IsNumeric(varResult) Then
objTarget.Cells(varResult + 1, 13) = rngC.Value
End If
End If
Next
'#################
'GM-Meldungen
Set rng = .Range("N2:N" & .Cells(Rows.Count, 2).End(xlUp).Row)
Set rngF = objTarget.Range("B2:B100")
For Each rngC In rng
If rngC "" Then
varResult = Application.Match(rngC.Offset(0, -12), rngF, 0)
If IsNumeric(varResult) Then
objTarget.Cells(varResult + 1, 14) = rngC.Value
End If
End If
Next
'#################
'Produktverkauf
Set rng = .Range("O2:O" & .Cells(Rows.Count, 2).End(xlUp).Row)
Set rngF = objTarget.Range("B2:B100")
For Each rngC In rng
If rngC "" Then
varResult = Application.Match(rngC.Offset(0, -13), rngF, 0)
If IsNumeric(varResult) Then
objTarget.Cells(varResult + 1, 15) = rngC.Value
End If
End If
Next
'#################
'Abnahmen
Set rng = .Range("P2:P" & .Cells(Rows.Count, 2).End(xlUp).Row)
Set rngF = objTarget.Range("B2:B100")
For Each rngC In rng
If rngC "" Then
varResult = Application.Match(rngC.Offset(0, -14), rngF, 0)
If IsNumeric(varResult) Then
objTarget.Cells(varResult + 1, 16) = rngC.Value
End If
End If
Next
'######################
End Select
End With
Next
' >>>>>>>>>> Etally speichern
Application.Calculate
'strNewName = "Etally" & objTarget.Cells(9, 2).Text & Mid(objWB.Name, InStrRev(objWB.Name, "."))
'objWB.SaveAs "C:\MLC2009e\Etally_TreffenAblage" & "\" & strNewName 'Speichern unter vorgegebenem Pfad
'##############
ActiveWorkbook.Close SaveChanges:=True
'######################
'ActiveSheet.Range("B2").Activate
'
'
' objWB.Close
MsgBox "Fertig", vbInformation, "MLC2009e 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