Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Tabelle öffnen in Abhängigkeit von Zelleintrag

Tabelle öffnen in Abhängigkeit von Zelleintrag
Zelleintrag
Guten Morgen allesreits,
Suche einen Code mit dem ich ein bestimmtes Tabellenblatt einer Zieldatei in ABHÄNGIGKEIT von einem Zelleintrag der Quelldatei öffnen kann.
Habe eine Zieldatei mit 10 inhaltlich gleichen Sheets, die aber einen unterschiedlichen Zeitraum auswerten.
Ich verwende derzeit "Set objTarget = objWB.Sheets(1)", um das Sheet 1 automatisch anzusprechen.
Nun möchte aber keine Festlegung mehr haben, sondern möchte es variabel halten
a) entweder das Makro soll nach dem Öffnen der Mappe anhalten, so dass ich zunächst die Möglichkeit habe, das Sheet auszuwählen oder noch besser
b) Wenn beispielsweise in der Quelldatei im Sheet "Basisdaten" in sagen wir A2 eine 5 steht soll das Sheet 5 der Zieldatei geöffnet werden.
Jemand eine Idee?
Besten Dank vorab.
Dietmar aus Aachen

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
vielleicht geht es so.
25.10.2009 11:42:04
Tino
Hallo,
nicht getestet.
With ThisWorkbook.Sheets("Basisdaten")
If IsNumeric(.Range("A2")) And .Range("A2")  "" Then
Set objTarget = objWB.Sheets(.Range("A2"))
Else
Set objTarget = objWB.Sheets(1)
End If
End With
Gruß Tino
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

Anzeige
was mir auffällt ohne zu testen weil
25.10.2009 12:45:41
Tino
Hallo,
der nachbau mir zu aufwändig ist, Du hast nicht alle Zellbezüge 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
With ThisWorkbook.Sheets("Eingangsseite")
If IsNumeric(.Range("R22")) And .Range("R22")  "" Then
Set objTarget = objWB.Sheets(.Range("R22"))
Else
Set objTarget = objWB.Sheets(1)
End If
End With

Gruß Tino
Anzeige
AW: vielleicht geht es so.
25.10.2009 14:17:58
Dietmar
Hallo Tino,
ups, hatte ich doch glatt übersehen.
Leider geht es doch nicht. Der Rückgriff auf die Quelldatei scheint nicht zu funktionieren.
Vielleicht fällt Dir ja noch etwas ein.
Zum Nachbau ist es sicherlich zu umfangreich.
Viele Grüße
Dietmar aus Aachen
AW: vielleicht geht es so.
25.10.2009 14:25:28
Dietmar
Hallo Tino!
Es geht !!!!!
Hatte doch noch eine individuelle Anpassung vergessen.
Klasse!
DANKE!
Viele Grüße
Dietmar aus Aachen
ein bar Ungereimtheiten...
25.10.2009 14:31:59
Tino
Hallo,
falle mir im Bezug zu Deiner Ausgangsfrage schon auf.
Du hast von Sheet "Basisdaten" A2 geschrieben und
im Code hast Du es auf Sheets("Eingangsseite") R22 geändert.
Wo genau steht den der Code, in der Datei wo sich auch die besagte Tabelle
Basisdaten oder Eingangsseite befindet?
Mach mal zu testzwecken die Error Behandlung (On Error GoTo ErrExit) raus,
vielleicht erkennt man so besser wo der Fehler liegt.
Gruß Tino
Anzeige
Zuviel Druck! Millibar tun's auch... ;-) Gruß owT
26.10.2009 00:17:05
Luc:-?
:-?
AW: Zuviel Druck! Millibar tun's auch... ;-) Gruß owT
28.10.2009 16:29:48
Dietmar
Danke Tino,
Problem war, dass ich die Umsetzung aus der Beispeidatei in die Echtdatei nicht korrekt vorgenommen hatte.
Dein Code funzt einwandfrei!
LG
Dietmar aus Aachen

343 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige