27.08.2015

Geschlossene Dateien - Range und Summe bestimmter Zellen...

Geschlossene Dateien. Zellen werden über ein Array ausgelesen - inklusive Unterordner (optional). Bestimmte Zellen werden summiert. Nur Dateien die einem bestimmten Muster folgen, werden eingelesen. In diesem Beispiel - kein "eta" im Dateiname. Die Summe wird über "ExecuteExcel4Macro" realisiert.

Closed files. Cells are read on an array - including subfolders (optional). Certain cells are summed. Only files that follow a certain pattern are read. In this example - no "eta" in the File Name. The sum will be implemented via "ExecuteExcel4Macro".

Hier noch eine Beispieldatei / Here's a sample file:
Geschlossene Dateien - Range und Summe bestimmter Zellen...[ZIP 900 KB]

' Variablendeklaration erforderlich
Option Explicit
' Der Tabellenblattname in den auszulesenden Dateien
Const strSheetQ As String = "Tabelle1"
' Der Tabellenblattname in DIESER Datei (die mit dem Code)
Const strSheetZ As String = "Werte"
' Diese Zellen werden Summiert
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Files_Read_1
' Author    : © Case (Ralf Stolzenburg)
' Date      : 27.08.2015
' Purpose   : Geschlossene Dateien - mehrere Zellen auslesen - Array...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim blnUpdate As Boolean
    Dim objShell As Object
    Dim intCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        .ScreenUpdating = False
        blnUpdate = .AskToUpdateLinks
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Wenn Du einen Ordnerauswahldialog möchtest
    'Set objShell = CreateObject("Shell.Application")
    'Set varDir = objShell.BrowseForFolder(0, "Ordner", &H4000, 17)
    'If varDir Is Nothing Then Set objShell = Nothing: Exit Sub
    'strDir = varDir.Self.Path
    ' Datei im gleichen Ordner wie Auswertungsdateien
    strDir = ThisWorkbook.Path
    'strDir = "C:\Temp\Los\"  ' Fester Pfad
    Set objDir = objFSO.GetFolder(strDir)
    ' Der Code bezieht sich auf ein bestimmtes Objekt
    ' Hier strSheetZ
    ' Alles was sich auf dieses "With" bezieht
    ' MUSS mit einem Punkt beginnen
    With ThisWorkbook.Worksheets(strSheetZ)
        ' Inhalt von Tabelle "strSheetZ" wird ab Zeile 2 gelöscht
        .Rows("2:" & .Rows.Count).ClearContents
        ' Mit Unterordner
        dirInfo objDir, "*.xls*", True
        ' Ohne Unterordner
        'dirInfo objDir, "*.xls*"
        ' Formeln entfernen - Werte bleiben erhalten
        .UsedRange.Value = .UsedRange.Value
    End With
Fin:
    ' Setze die Objektvariablen auf Nothing
    Set objDir = Nothing
    Set objFSO = Nothing
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = blnUpdate
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = 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
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : dirInfo
' Author    : © Case (Ralf Stolzenburg)
' Date      : 27.08.2015
' Purpose   : Geschlossene Dateien - mehrere Zellen auslesen - Array...
'--------------------------------------------------------------------------
' Rekursive Sub mit Array - Optional mit Unterordner
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    ' Variablendeklaration
    Dim strFormula As String
    Dim lngLastRow As Long
    Dim arrCell As Variant
    Dim intTMP As Integer
    Dim varTMP As Variant
    ' Weitere Zellen nach gleichem Muster in das Array einfügen
    arrCell = Array("A1", "C1", "E2", "H8", "I8", _
        "H16", "I16", "H24", "I24", "H32", "I32", "C8", _
        "D8", "C16", "D16", "C24", "D24", "C32", "D32")
    ' Alle Dateien im vorgegebenen Ordner
    For Each varTMP In objCurrentDir.Files
        ' Dateiname entspricht den Vorgaben und ist nicht DIESE Datei
        ' Falls im gleichen Ordner und ist KEINE temporäre Datei
        ' Dateiname mit "eta" im Namen werden NICHT eingelesen!!!!!
        If varTMP.Name Like strName And varTMP.Name <> _
            ThisWorkbook.Name And Left(varTMP.Name, 1) <> "~" Then
            If Not varTMP.Name Like "*eta*" Then
                ' Der Code bezieht sich auf ein bestimmtes Objekt
                ' Hier strSheetZ
                ' Alles was sich auf dieses "With" bezieht
                ' MUSS mit einem Punkt beginnen
                With ThisWorkbook.Worksheets(strSheetZ)
                    ' Letzte Zeile bezogen auf Spalte A plus 1
                    lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                        .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
                    ' Schleife über alle Zellen des Arrays
                    For intTMP = LBound(arrCell) To UBound(arrCell)
                        ' Hier würde jetzt noch der Dateiname mit Pfad
                        ' in die nächste freie Spalte geschrieben
                        '.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Path
                        ' Hier würde jetzt noch der Dateiname
                        ' in die nächste freie Spalte geschrieben
                        '.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Name
                        ' Werte über Formel holen, Tabellenblatt über "Const..."
                        ' oben definiert, Zelle über Array. Formel in Spalte A folgende...
                        strFormula = "'" & Mid(varTMP.Path, 1, InStrRev(varTMP.Path, "\")) & _
                            "[" & Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & strSheetQ & "'!"
                        .Cells(lngLastRow, intTMP + 1).Formula = "=" & strFormula & arrCell(intTMP)
                    Next intTMP
                    .Cells(lngLastRow, 20).Value = ExecuteExcel4Macro(strFormula & "R18C6") + _
                        ExecuteExcel4Macro(strFormula & "R26C6") + _
                        ExecuteExcel4Macro(strFormula & "R34C6")
                    .Cells(lngLastRow, 21).Value = ExecuteExcel4Macro(strFormula & "R21C6") + _
                        ExecuteExcel4Macro(strFormula & "R29C6") + _
                        ExecuteExcel4Macro(strFormula & "R37C6")
                End With
            End If
        End If
    Next varTMP
    ' Wenn die Variable blnTMP "True" ist (in der Sub "Files_Read_1" vorgegeben
    ' Dann durchsuche auch alle Unterordner
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
End Sub

22.08.2015

Word - UserForm - ComboBox - TextBoxen - Daten aus Excel ziehen...

Eine Userform in Word. Die Combobox wird mit Daten aus Excel gefüllt. Bei Auswahl eines Namens werden die Textboxen mit den zugehörigen Daten befüllt. Die Exceldatei wird zu Beginn ausgeblendet geöffnet und beendet, wenn die Userform geschlossen wird. Die Word- und Exceldatei müssen im gleichen Verzeichnis sein.

A UserForm in Word. The combo box is filled with data from Excel. When you select a name, the text boxes are filled with the corresponding data. The Excel file is opened hidden at the start and ends when the UserForm is closed. The Word and Excel file must be in the same directory.

Hier noch eine Beispieldatei / Here's a sample file:
Word - UserForm - ComboBox - TextBoxen - Daten aus Excel ziehen...[ZIP 35 KB]

' Variablendeklaration erforderlich
Option Explicit
' Konstanten - da Late Binding also KEIN Verweis auf Excelbibliothek
Const xlFormulas = -4123
Const xlColumns = 2
Const xlUp = -4162
Const xlWhole = 1
'--------------------------------------------------------------------------
' Module    : UserForm1
' Procedure : UserForm_Initialize
' Author    : © Case (Ralf Stolzenburg)
' Date      : 22.08.2015
' Purpose   : Excel öffnen, Daten aus Adressliste per Find ziehen...
'--------------------------------------------------------------------------
' Variablendeklaration ausserhalb - weil auch andere Prozeduren zugreifen
    Dim lngLastRow As Long
    Dim objSheet As Object
    Dim blnTMP As Boolean
    Dim objExel As Object
Private Sub UserForm_Initialize()
    ' Variablendeklaration
    Dim lngTMP As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Exceldatei ausgeblendet öffnen
    Set objExel = GetObject(ThisDocument.Path & "\AdressListe.xls")
    ' Zugriff auf das erste Tabellenblatt
    Set objSheet = objExel.Worksheets(1)
    ' Oder mit Namen
    'Set objSheet = objExel.WorkSheets("Adressen")
    With objSheet
        ' letzte belegte Zeile im Excelsheet in Spalte A ermitteln
        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        ComboBox1.Clear
        ' Erster Eintrag in der Combobox
        ComboBox1.AddItem ("Auswahl...")
        ' Schleife um die Combobox zu befüllen
        For lngTMP = 2 To lngLastRow
            ComboBox1.AddItem (.Range("A" & lngTMP))
        Next lngTMP
        ' Combobox auf ersten Eintrag setzen
        ComboBox1.ListIndex = 0
    End With
    blnTMP = True
Fin:
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub ComboBox1_Change()
    ' Variablendeklaration
    Dim lngTMP As Long
    Dim lngRow As Long
    On Error GoTo Fin
    ' Da schon beim befüllen der Combobox das Change-Event ausgeführt
    ' wird - hier unterbunden mit einer Boolean-Variablen
    If blnTMP Then
        ' Wenn nicht der erste Eintrag angezeigt wird dann...
        If ComboBox1.ListIndex > 0 Then
            ' Finde in Excel die Zeile mit dem Inhalt von Combobox1
            lngRow = objSheet.Range("A2:A" & lngLastRow).Find _
                (ComboBox1.Value, LookIn:=xlFormulas, _
                LookAt:=xlWhole, SearchOrder:=xlColumns).Row
            ' Befülle die Textboxen mit den korrespondierenden Werten
            For lngTMP = 1 To 4
                Me.Controls("TextBox" & lngTMP).Text = _
                    objSheet.Cells(lngRow, lngTMP + 1).Text
            Next lngTMP
        Else
            ' Sonst also wenn Auswahl... bzw. Listindex <=0 dann Textboxen leeren
            For lngTMP = 1 To 4
                Me.Controls("TextBox" & lngTMP).Text = ""
            Next lngTMP
        End If
    End If
Fin:
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub CommandButton1_Click()
    ' Userform beenden
    Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    ' Wenn NICHT das "x" geklickt wurde dann...
    If CloseMode <> 0 Then
        ' Excel schliessen
        objExel.Close False
        ' Objektvariable leeren
        Set objSheet = Nothing
        Set objExel = Nothing
    Else
        ' Sonst mache nichts bzw. breche das beenden ab
        Cancel = True
    End If
End Sub

Word - Kontrollkästchen (Formularsteuerelement) auslesen...

Aus allen Worddateien sollen die Kontrollkästchen (Formularsteuerelement) ausgelesen werden - Haken gesetzt oder nicht. Auch ein Textfeld (F...