Geschlossene Dateien - Zelle - Reihenfolge...

Frage: In Spalte A steht eine ID. Dies ist der Dateiname ohne Extension. Die Dateien sind im gleichen Verzeichnis wie die Datei mit dem Code. Inhalt der Zelle B4 aus den Dateien in Spalte B zu dem entsprechenden Eintrag aus Spalte A.

Column A is an ID. This is the file name without the extension. The files are in the same directory as the file containing the code. Contents of cell B4 of the files in column B to the corresponding entry in column A.

Hier noch eine Beispieldatei / Here's a sample file:
Geschlossene Dateien - Zelle - Reihenfolge...[ZIP 120 KB]

Richtige Reihenfolge / correct order...

Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.01.2013
' Purpose   : Closed files Specific Cell...
'--------------------------------------------------------------------------
' Tabellenblatt in den auszulesenden Dateien - also ggf. anpassen!!
Const strSheet As String = "result"
Sub Main()
    Dim strFileEx As String
    Dim strWBook As String
    Dim rngFound As Range
    Dim lngCalc As Long
    Dim lngRow As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    lngRow = 2
    strWBook = Dir$(ThisWorkbook.Path & _
        Application.PathSeparator & "*.xls*", vbNormal)
    With ThisWorkbook.Worksheets("Sheet1")
        .Range("B2:B" & .Rows.Count) = ""
        Do While strWBook <> ""
            If strWBook <> ThisWorkbook.Name Then
                strFileEx = Left(strWBook, (InStrRev(strWBook, ".") - 1))
                Set rngFound = .Columns(1).Find(What:=strFileEx, _
                    LookIn:=xlValues, _
                    LookAt:=xlPart, _
                    MatchCase:=False)
                If Not rngFound Is Nothing Then
                    With .Cells(rngFound.Row, 2)
                        .Formula = "='" & ThisWorkbook.Path & _
                        "\[" & strWBook & "]strSheet'!B4"
                        .Value = .Value
                    End With
                    lngRow = lngRow + 1
                End If
            End If
            strWBook = Dir$()
            Set rngFound = Nothing
        Loop
        .UsedRange.Columns(2).SpecialCells(xlCellTypeBlanks).Value = _
            "No file or misspelled"
    End With
Fin:
    Set rngFound = Nothing
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Not Err.Number = 1004 Then
        If Err.Number <> 0 Then MsgBox "Error: " & _
            Err.Number & " " & Err.Description
    End If
End Sub

Falsche Reihenfolge - wenn Spalte A nicht massgebend... / Wrong order - if column A is not decisive...

Option Explicit
'--------------------------------------------------------------------------
' Module    : Module2
' Procedure : Main_1
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.01.2013
' Purpose   : Closed files Specific Cell...
'--------------------------------------------------------------------------
' Tabellenblatt in den auszulesenden Dateien - also ggf. anpassen!!
Const strSheet As String = "result"
Sub Main_1()
    Dim strWBook As String
    Dim lngCalc As Long
    Dim lngRow As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    lngRow = 2
    strWBook = Dir$(ThisWorkbook.Path & _
        Application.PathSeparator & "*.xls*", vbNormal)
    With ThisWorkbook.Worksheets("Sheet1")
        .Range("D2:D" & .Rows.Count) = ""
        Do While strWBook <> ""
            If strWBook <> ThisWorkbook.Name Then
                With .Cells(lngRow, 4)
                    .Formula = "='" & ThisWorkbook.Path & _
                        "\[" & strWBook & "]strSheet'!B4"
                    .Value = .Value
                End With
                lngRow = lngRow + 1
            End If
            strWBook = Dir$()
        Loop
    End With
Fin:
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...