Clever-Excel-Forum

Hallo liebe Community,

ich bin in der Arbeit auf eine neue Challenge getroffen.

Ich soll für meinen Chef ein Excel-Makro schreiben, was anhand eine Liste mit all den Daten, die man manuell eingibt, erstellt.

Ich veranschauliche es an einem Beispiel.

Ich habe ca. 2000 Excel-Files im selben Ordner.
All diese Excel-Files haben fast das selbe Schema. Tabelle 1 heißt "Informationsblatt". In C2 befindet sich der Gerätename, in C3 die Seriennummer und in C4 die Softwareversion.

Was möchte ich?

Ein Makro, mit dem ich eingebe "C2 = PA" und "C3 = 0D49" und z.B. "C4 = <4.9". Das heißt, er soll alle Excel-Files, inklusive der Zellen schön in eine Liste packen, die als Gerätename PA, als Seriennummer 0D49 und als Softwareversion kleiner als 4.9 haben.

Das ist bis jetzt mein Code:

Code:
Option Explicit

Public Sub Files_Read()

Const strSheetQ As String = "Informationsblatt" ' Die Tabelle wird ausgelesen

Const strSheetZ As String = "Tabelle1" ' Die Tabelle in dieser Datei

Const strCellQ1 As String = "C3" ' Die Zelle wird ausgelesen

Const strCellQ2 As String = "C4"

Const strCellQ3 As String = "C5"

    Dim stCalc As Integer

    Dim strDir As String

    Dim objFSO As Object

    Dim objDir As Object

    On Error GoTo Fin

    With Application

        .ScreenUpdating = False

        .AskToUpdateLinks = False

        .EnableEvents = False

        stCalc = .Calculation

        .Calculation = xlCalculationManual

        .DisplayAlerts = False

    End With

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    strDir = ThisWorkbook.Path  ' Datei im gleichen Ordner wie Auswertungsdateien

    Set objDir = objFSO.GetFolder(strDir)

    'dirInfo objDir, "*.xls", True ' Mit Unterordner

    dirInfo objDir, "*.xls"

Fin:

    With Application

        .ScreenUpdating = True

        .AskToUpdateLinks = True

        .EnableEvents = True

        .Calculation = stCalc

        .DisplayAlerts = True

    End With

    Set objDir = Nothing

    Set objFSO = Nothing

End Sub

Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _

    Optional ByVal blnTMP As Boolean = False)

    Dim objWorkbook As Workbook

    Dim strFormula As String

    Dim lngLastRow As Long

    Dim varTMP As Variant

    Const strSheetQ As String = "Informationsblatt" ' Die Tabelle wird ausgelesen

Const strSheetZ As String = "Tabelle1" ' Die Tabelle in dieser Datei

Const strCellQ1 As String = "C3" ' Die Zelle wird ausgelesen

Const strCellQ2 As String = "C4"

Const strCellQ3 As String = "C5"

    For Each varTMP In objCurrentDir.Files

        If varTMP.Name Like strName And varTMP.Name <> ThisWorkbook.Name Then

            With ThisWorkbook.Worksheets(strSheetZ)

                lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _

                    .Rows.Count, .Cells(.Rows.Count, 2).End(xlUp).Row) + 1

                With .Cells(lngLastRow, 2)

                    .Formula = "='" & Mid(varTMP.Path, 1, _

                        InStrRev(varTMP.Path, "\")) & "[" & _

                        Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _

                        strSheetQ & "'!" & strCellQ1

                    .Offset(0, -1).Value = varTMP.Name

                End With

                With .Cells(lngLastRow, 3)

                    .Formula = "='" & Mid(varTMP.Path, 1, _

                        InStrRev(varTMP.Path, "\")) & "[" & _

                        Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _

                        strSheetQ & "'!" & strCellQ2

                End With

                With .Cells(lngLastRow, 4)

                    .Formula = "='" & Mid(varTMP.Path, 1, _

                        InStrRev(varTMP.Path, "\")) & "[" & _

                        Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _

                        strSheetQ & "'!" & strCellQ3

                End With

                .UsedRange.Value = .UsedRange.Value

            End With

        End If

    Next varTMP

    If blnTMP = True Then

        For Each varTMP In objCurrentDir.SubFolders

            dirInfo varTMP, strName

        Next varTMP

    End If

    Set objWorkbook = Nothing

End Sub

Er liest aber alle Excel-Files aus und schreibt diese auch schön in eine Liste, aber ich möchte sie gleich manuell filtern können. Am besten wäre es, wenn man die gesuchten Daten einfach in eine Zelle oder in ein Textfeld schreibt.

Wisst ihr, was ich meine? Ich bin leider (noch) kein Profi in VBA. :D

Danke an euch!!

Liebe Grüße
Instant

Hallo,

Zitat:Ich habe ca. 2000 Excel-Files im selben Ordner.

All diese Excel-Files haben fast das selbe Schema.

Was bedeutet fast .

Ansonsten würde ich sagen , das ist was für PowerQuery.

(12.12.2019, 11:30)Dieter63 schrieb: [ -> ]Hallo,

Was bedeutet fast .

Ansonsten würde ich sagen , das ist was für PowerQuery.

Fast bedeutet, dass es auch Files gibt die nicht das Schema haben weil sie Vorlagen, also gänzlich andere Dokumente sind. Aber es wäre kein Problem, nur die Files die ausgewertet werden müssen in einem Ordner zu haben.

Von PowerQuery habe ich schon gehört. Wäre das die beste Lösung? Danke.

LG

Hallo,

die beste Lösung gibt es nicht

Nach deiner Beschreibung ist das eine Möglichkeit , ich kenne deine Anwendung nicht im Detail.

Du kannst dir ja mal einige Files in einen Testordner kopieren und dann mit Daten -> Daten abrufen -> aus Ordner ausprobieren

Hallo

was passiert beim auflisten, wenn du hinter dem letzten End With und .UsedRange.Value diesen Auswertungs Code einfügst?
Nach meiner Ansicht ist das die einfachste Art die gewünschten Daten auszufiltern. Indem man die unerwünschten einfach wieder löscht!!

mfg Gast 123

Code:
              End With  ' = .Cells(lngLastRow, 4)

               '"C2 = PA" und "C3 = 0D49" und z.B. "C4 = <4.9"

               If .Cells(lngLastRow, 2) = "PA" And .Cells(lngLastRow, 3) = "0D49" Then _

               If .Cells(lngLastRow, 4) < 4.9 Then .Cells(lngLastRow, 2).Resize(1, 3) = Empty

               .UsedRange.Value = .UsedRange.Value

Nachtrag: deine Programmierung ist exellent, das ist KEIN Anfaengerwerk! Da muss ich mich richtig anstrengen da mitzuhalten'
Nach 20 Jahren Excel Programmieren hat man aber bestimmte Erfahrungen gesammt, wie man Probleme am einfachsten lösen könnte ...

(12.12.2019, 11:47)Dieter63 schrieb: [ -> ]Hallo,

die beste Lösung gibt es nicht

Nach deiner Beschreibung ist das eine Möglichkeit , ich kenne deine Anwendung nicht im Detail.

Du kannst dir ja mal einige Files in einen Testordner kopieren und dann mit Daten -> Daten abrufen -> aus Ordner ausprobieren

Ich werds probieren, der PowerQueryEditor schaut ja recht vielversprechend aus. Danke.

@Gast123

Ich habs ehrlich gesagt nicht selber programmiert, habs mir selber im Internet zusammengesucht.

Naja...aber ich brauche ja auch eine Art Eingabefeld...und ich möchte ja nach dem Inhalt der Zelle filtern.

Hallo

kein Problem, wenn du Variable sein willst dann stelle den Code einfach um! Lade dir die drei Vergleichswerte VOR der For Bext Schleife in drei Variablen, z.B. VG1-3, und vergleiche nach der Formel die Zeile ob dieser Wert vorkommt? In welchem Sheet die Vergleichswerte stehen kannst du selbst entscheiden. Und dann aus dem Sheet laden.

mfg Gast 123

Code:
Dim VG1, VG2, VG3 As Variant

   VG1 = Worksheets("aaa").Range("xxx").Value 'Zelle für Vergleichswerte bitte selbst festlegen ....

   VG2 = Worksheets("aaa").Range("yyy").Value

   VG3 = Worksheets("aaa").Range("zzz").Value

   For Each varTMP In objCurrentDir.Files

       'Hier der normale Code, nach den letzten End With die Auswertung!

              '"C2 = PA" und "C3 = 0D49" und z.B. "C4 = <4.9"

              If .Cells(lngLastRow, 2) = VG1 And .Cells(lngLastRow, 3) = VG2 Then _

              If .Cells(lngLastRow, 4) < VG3 Then .Cells(lngLastRow, 2).Resize(1, 3) = Empty

              .UsedRange.Value = .UsedRange.Value

Instant_

Dieter63

Instant_

Dieter63

Gast 123

Instant_

Gast 123