03.01.2013

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

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...