Microsoft Office Forum [ www.Office-Fragen.de ] >> READONLY <<

Microsoft Office 2003-2019 => Excel => Thema gestartet von: lklk am Juni 30, 2016, 09:11:04 Vormittag

Titel: Makro mit bestimmter Reihenfolge
Beitrag von: lklk am Juni 30, 2016, 09:11:04 Vormittag

Guten Morgen,

ich habe ein Makros geschrieben, um bestimmte Messergebnisse auszuwerten. Allerdings habe ich während des Einsatzes festgestellt, dass es Probleme gibt, sobald die einzulesende Datei eine Zeile zu wenig hat.
Zur Veranschauung einer Messwertangabe:

In den Zeilen (1) steht, was gemessen wurde: z.B. Außendurchmesser
In der Spalte (A) steht das dazugehörige Ergebnis: z.B 0,5

Mein Makros nimmt jetzt diese Werte und kopiert sie. Sobald jetzt aber im einzulesenden Dokument eine Zeile anders ist/fehlt, dann rückt mir das Makros alle Ergebnisse eine Spalte nach links im Excel file.

Hier ein Ausschnitt meines Codes:

Sub Merge_CMM_Files(Source_Folder, SuchString, TableName As String)


    Dim objFileSearch As clsFileSearch
    Dim lngIndex As Long
    Dim lngcount As Long
    Dim dataSets As Variant
   
   
   
       
    Set objFileSearch = New clsFileSearch
    With objFileSearch
        .CaseSenstiv = True
        .Extension = "*.xls"
        .FolderPath = Source_Folder
        .SearchLike = SuchString
        .SubFolders = True
   
       

                If .Execute(Sort_by_name, Sort_Order_Ascending) > 0 Then  'Gefunden!
                   
                    'Anzeige wie viele Datein gefunden wurden
                    If MsgBox("Es wurden " & .FileCount & " Dateien gefunden. Wollen sie diese Dateien mergen?", vbYesNo, "Mehrfach-Fund   = vbYes Then
                        dataSets = .FileCount
                        Application.EnableEvents = False
                        Sheets.Add
                        Application.EnableEvents = True
                        Sheets.Item(1).Name = TableName
                       
                       
                       'Merkmalsbeschreibungen aus erster Datei laden
                        Application.EnableEvents = False    'Startmakros in den Datendateien blockieren
                        Workbooks.Open Filename:=.Files(1).strPath
                        Application.EnableEvents = True     'Makros aktivieren
                                 
                       

                        ActiveWindow.Close Savechanges:=False
                       
                       
                        For lngcount = 1 To .FileCount 'routine für datei öffnen, daten kopieren, datei schliessen.
                       
                       
                                ' Einzelne Datei öffnen
                                Application.EnableEvents = False    'Startmakros in den Datendateien blockieren
                               
                                Workbooks.Open Filename:=.Files(lngcount).strPath
                                Application.EnableEvents = True     'Makros aktivieren
                               
                                'Kopfdaten kopieren
                                'Measurementplan
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("B4").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(1, 1).Select
                                ActiveSheet.Paste
                               
                                'Operator
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("B10").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(1, 2).Select
                                ActiveSheet.Paste
                               
                                'Date
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("D4").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(1, 3).Select
                                ActiveSheet.Paste
                               
                               
                                'Time
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("D7").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(1, 4).Select
                                ActiveSheet.Paste
                               
                                'Order
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("F4").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(1, 5).Select
                                ActiveSheet.Paste
                               
                                'Part No
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("F7").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(1, 6).Select
                                ActiveSheet.Paste
                               
                                'Ebh_Z_PF BezB
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("A14").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(1, 7).Select
                                ActiveSheet.Paste
                               
                                'F3 Ø 242j6 BezC
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("A15").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(1, 8).Select
                                ActiveSheet.Paste
                               
                                'Rdht_Z_ø242j6_BezC
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("A16").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(1, 9).Select
                                ActiveSheet.Paste
                               
                                'Rdlf_ø242j6_BezC zu A
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("A17").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(1, 10).Select
                                ActiveSheet.Paste
                               
                               


                                 
                                 
                                'Measurement Plan kopieren
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("B5").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(2 + lngcount, 1).Select
                                ActiveSheet.Paste
                               
                                'Operator kopieren
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("B11").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(2 + lngcount, 2).Select
                                ActiveSheet.Paste
                               
                                'Date kopieren
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("D5").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(2 + lngcount, 3).Select
                                ActiveSheet.Paste
                               
                               
                               
                               
                                'Time kopieren
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("D8").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(2 + lngcount, 4).Select
                                ActiveSheet.Paste
                               
                                'Order kopieren
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("F5").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(2 + lngcount, 5).Select
                                ActiveSheet.Paste
                               
                                'Part No. kopieren
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("F8").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(2 + lngcount, 6).Select
                                ActiveSheet.Paste
                               
                                'Ebh_Z_PF BezB kopieren
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("B14").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(2 + lngcount, 7).Select
                                ActiveSheet.Paste
                               
                                'F3 Ø 242j6 BezC
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("B15").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(2 + lngcount, 8).Select
                                ActiveSheet.Paste
                               
                                'Rdht_Z_ø242j6_BezC kopieren
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("B16").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(2 + lngcount, 9).Select
                                ActiveSheet.Paste
                               
                                'Rdlf_ø242j6_BezC zu A kopieren
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                Range("B17").Select
                                Application.CutCopyMode = False
                                Selection.Copy
                                Windows("Merge_CMM.xls").Activate
                                Cells(2 + lngcount, 10).Select
                                ActiveSheet.Paste
                               
                                                               
                                'Datei Schliessen
                                Windows(Dir(.Files(lngcount).strPath, vbDirectory)).Activate
                                ActiveWindow.Close Savechanges:=False
                               
                           
                        Next lngcount
                 
                   
                    End If
             
                 
                End If

           
End With
Set objFileSearch = Nothing
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub



Ich hoffe mir kann jemanden weiter helfen.
Grüße
Lena

Titel: Antw: Makro mit bestimmter Reihenfolge
Beitrag von: maninweb am Juli 02, 2016, 09:36:32 Vormittag

Hallo,

in dem Code wird die Klasse clsFileSearch verwendet, die nicht jeder haben dürfte (auch wenn ich mir vorstellen kann, von wem die kommt).
Somit kann der Code nicht getestet werden und das Antworten wird schwierig. Insofern empfehle ich Dir, hier eine Beispieldatei zur Verfügung
zu stellen + eine Einlese/Auslesedatei.

Gruß