VBA: Werte aus geschlossener Datei holen!

[HZ25]

Hallo,


Folgender Code funktioniert im Augenblick nur wenn beide Datein offen sind, würde aber gerne, dass die Quelldatei geschlossen bleiben kann. Wie kann ich ihm das beibringen. Hab es leider nicht hinbekommen.
Die Quelldatei liegt auf einem Netzwerkpfad.

Ich habe auch mal das Modul als Anhang, das ist übersichtlicher.

Kann mir bitte mal jemand helfen?

Code:

Sub Suchen_Sachnummer()

Dim letzte As Long
Dim wkbName As Variant
Dim QsName As Variant
Dim SMsName As String
Dim SuchObj As Variant
Dim shName As Variant
Dim Zeile1 As Variant
Dim Zeile2 As Variant
Dim wkbMaske As String
Dim ZielZelle As Integer
Dim QuellZelle As Integer

Application.Calculation = xlCalculationManual

 ' wkbName = "\\hsir04\MES-I\Bestueckung\ASM_Rüstungen\01_Muster\01_Rüstlisten_Tool.xls"

  'Quell Workbook Name
 wkbName = "01_Rüstlisten_Tool.xls"
  'Quell Sheet Name
 QsName = "Rüstung"
  'Suchmaske Sheet Name
 SMsName = "Suchen"
  ' Suchmaske Workbook Name
 wkbMaske = Application.ActiveWorkbook.Name
  ' Objekt das gesucht wird
  SuchObj = Workbooks(wkbMaske).Sheets(SMsName).Cells(4, 3).Value
  ' Löschen vorherige Eingabe
 Range("H6:N100").ClearContents
  ' Letzte zeile Quell Workbook finden
     letzte = Workbooks(wkbName).Sheets(QsName).Cells(Rows.Count, 5).End(xlUp).Rows.Row
   
  ' Kopiern

         ZielZelle = 6
         QuellZelle = 5
         For D = QuellZelle To letzte
         With Workbooks(wkbName)
                  If .Sheets(QsName).Cells(QuellZelle, 5) = SuchObj Then
                                                  
                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 1).Value
                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 8) = Zeile1
                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 2).Value
                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 9) = Zeile1
                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 3).Value
                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 10) = Zeile1
                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 4).Value
                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 11) = Zeile1
                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 5).Value
                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 12) = Zeile1
                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 6).Value
                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 13) = Zeile1
                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 7).Value
                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 14) = Zeile1
                                                                  
               QuellZelle = QuellZelle + 1
               ZielZelle = ZielZelle + 1
               
               Else
               
               QuellZelle = QuellZelle + 1
               
            End If
            End With
            Next D
          
            Application.Calculation = xlCalculationAutomatic

Ich habe auch mal das Modul als Anhang, das ist übersichtlicher.

[Steffl]

Hallo,

Du könntest es mal mit der Function von Thomas Ramel versuchen

Function

Ich habe mal versucht, dies für dich anzupassen

Code:

Sub Suchen_Sachnummer()


Dim letzte As Long
Dim wkbName As Variant
Dim QsName As Variant
Dim SMsName As String
Dim SuchObj As Variant
Dim shName As Variant
Dim Zeile1 As Variant
Dim Zeile2 As Variant
Dim wkbMaske As String
Dim ZielZelle As Integer
Dim QuellZelle As Integer
Dim Pfad As String
Application.Calculation = xlCalculationManual

Pfad = "\\hsir04\MES-I\Bestueckung\ASM_Rüstungen\01_Muster\"

  'Quell Workbook Name
wkbName = "01_Rüstlisten_Tool.xls"
  'Quell Sheet Name
QsName = "Rüstung"
  'Suchmaske Sheet Name
SMsName = "Suchen"
  ' Suchmaske Workbook Name
wkbMaske = Application.ActiveWorkbook.Name
  ' Objekt das gesucht wird
  SuchObj = Workbooks(wkbMaske).Sheets(SMsName).Cells(4, 3).Value
  ' Löschen vorherige Eingabe
Range("H6:N100").ClearContents
  ' Letzte zeile Quell Workbook finden
     letzte = Workbooks(wkbName).Sheets(QsName).Cells(Rows.Count, 5).End(xlUp).Rows.Row
  
  ' Kopiern

         ZielZelle = 6
         QuellZelle = 5
         For D = QuellZelle To letzte
        
        
        
        
         With Workbooks(wkbName)
                  If .Sheets(QsName).Cells(QuellZelle, 5) = SuchObj Then
                     If GetDataCloseWB(Pfad, _
                     wkbName, _
                     QsName, _
                     "A" & QuellZelle & ":F" & QuellZelle, _
                     Worksheets(SMsName).Cells(Zielezelle, 8)) Then
                                                  
'                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 1).Value
'                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 8) = Zeile1
'                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 2).Value
'                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 9) = Zeile1
'                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 3).Value
'                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 10) = Zeile1
'                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 4).Value
'                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 11) = Zeile1
'                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 5).Value
'                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 12) = Zeile1
'                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 6).Value
'                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 13) = Zeile1
'                          Zeile1 = .Sheets(QsName).Cells(QuellZelle, 7).Value
'                          Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 14) = Zeile1
                                                                  
                        QuellZelle = QuellZelle + 1
                        ZielZelle = ZielZelle + 1
                  End If
               Else
              
               QuellZelle = QuellZelle + 1
              
            End If
            End With
            Next D
          
            Application.Calculation = xlCalculationAutomatic
End Sub

Public Function GetDataClosedWB(SourcePath As String, _
                                SourceFile As String, _
                                sourceSheet As String, _
                                SourceRange As String, _
                                TargetRange As Range) As Boolean

'Holt einen Bereich aus einer _geschlossenen_ Arbeitsmappe
'Nur in VBA zu verwenden; nicht aus einer Tabellenzelle heraus
'© t.ramel@mvps.org

Dim strQuelle       As String
Dim Zeilen          As Long
Dim Spalten         As Byte

   On Error GoTo InvalidInput

   strQuelle = "'" & SourcePath & "[" & SourceFile & "]" & _
               sourceSheet & "'!" & _
               Range(SourceRange).Cells(1, 1).Address(0, 0)

   Zeilen = Range(SourceRange).Rows.Count
   Spalten = Range(SourceRange).Columns.Count

   With TargetRange.Cells(1, 1).Resize(Zeilen, Spalten)
      .Formula = "=IF(" & strQuelle & "="""",""""," & strQuelle & ")"
      .Value = .Value
   End With

   GetDataClosedWB = True
   Exit Function

InvalidInput:
   MsgBox "Die Quelldatei oder der Quellbereich ist ungültig!", _
          vbExclamation, "Get data from closed Workbook"
   GetDataClosedWB = False
End Function

Bitte die Function auch mit kopieren und dies nicht an den Originaldateien probieren.

[HZ25]

Hallo,

danke für deine Mühe. Der Code funktioniert so aber auch nicht, da er die Datei bei With Workbooks(wkbName) nicht findet.

With Workbooks(wkbName)

                  If .Sheets(QsName).Cells(QuellZelle, 5) = SuchObj Then

                     If GetDataCloseWB(Pfad, _

                     wkbName, _

                     QsName, _

                     "A" & QuellZelle & ":F" & QuellZelle, _
                     Worksheets(SMsName).Cells(Zielezelle, 8)) Then


Habe daher meinen ursprünglichen Code einfach so gelassen und hole nun die ganze Datei mit dem "Thomas Ramel Code" in ein temporäres sheet, 

Gruß und Danke!