Application.FileSearch Sorunu

erdotsc · 12 Eylül 2012

Merhaba arkadaşlar,

İşimi oldukça hızlandıran makro programı var. Office2007 sürümüne geçiş yapıldığından dolayı kullanamıyorum. Site üzerinde bir çok konu buldum hepsini okumuş bulunmaktayım. Fakat bir türlü kullandığım makroya uygulayamadım.

Yardımcı olursanız çok sevinirim.

Kod:

Sub teilen_program()

'Daten aktualisieren

'Alle Meldungen aus
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

    ' alle Dateien des Ordners anzeigen in Indexdatei
    spf = 0
    mpf = 0
   Dim iCounter As Integer
   Dim sPath As String
   sPath = ActiveWorkbook.Path
   'abbruchbedingung
   If sPath = "" Then Exit Sub
   With Application.FileSearch
        .LookIn = sPath & "\NC_Programs\"
      .Filename = "*.*"
      .Execute
    If .Execute > 0 Then
    test2 = .FoundFiles.Count
        For i = 1 To .FoundFiles.Count
            'Oeffnen der Daten
            ZuÖffnendeDatei = .FoundFiles(i)
            Dateiname = Dir(.FoundFiles(i))
            ze = 0
            
            Open ZuÖffnendeDatei For Input As #1    'Datei in Speicher lesen
                Do While Not EOF(1)               'Schleife starten bis End of file erreicht
                
                test = LOF(1)
                
                Line Input #1, daten      'Zeilenweise einlesen
                ze = ze + 1         'Durchlaeufe Zaehlen
                'Einlesen der Daten
                    'Einlesen der SPF
                    If Right(daten, 3) = "SPF" _
                    And Left(daten, 1) = "%" Then
                        sp = 5
                        Do While Not Mid(daten, sp, 1) = Chr(95) And sp <= Len(daten)
                            sp = sp + 1
                        Loop
                        programname = Mid(daten, 5, sp - 5)
                        spf = spf + 1
                        'Datei erstellen
                        Open sPath & "\NC_Programs\Files_SPF\" & programname & ".SPF" For Output As #2
                            Do While Not EOF(1)         'Schleife starten bis End of file erreicht
                                Print #2, daten
                                Line Input #1, daten      'Zeilenweise einlesen
                                ze = ze + 1
                                If Right(daten, 3) = "M17" Then
                                    Print #2, daten
                                'ElseIf Right(daten, 3) = "RET" Then
                                    'Print #2, daten
                                    Exit Do
                                End If
                            Loop
                        Close #2    'neue Datei schließen
                    End If
                    
                    'Einlesen der MPF
                    If Right(daten, 3) = "MPF" _
                    And Left(daten, 1) = "%" Then
                        sp = 5
                        Do While Not Mid(daten, sp, 1) = Chr(95) And sp <= Len(daten)
                            sp = sp + 1
                        Loop
                        programname = Mid(daten, 5, sp - 5)
                        mpf = mpf + 1
                        'Datei erstellen
                        Open sPath & "\NC_Programs\Files_MPF\" & programname & ".SPF" For Output As #2
                            Do While Not EOF(1)         'Schleife starten bis End of file erreicht
                                Print #2, daten
                                Line Input #1, daten      'Zeilenweise einlesen
                                ze = ze + 1
                                If Right(daten, 3) = "M30" Then
                                    Print #2, daten
                                    Exit Do
                                End If
                            Loop
                        Close #2 'neue Datei schließen
                    End If
                Loop
                'Datei zum einlesen schließen
            Close #1
            
        Next i
    End If
    End With



'Alle Meldungen an
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox ("Einlesen erfolgreich. " & spf & " Unterprogramme verarbeitet " & mpf & " Hauptprogramme verarbeitet")


End Sub

hamitcan · 12 Eylül 2012

2007 ve 2010'da bu fonksiyon çalışmıyor. Forumda alternatif kodlar üretildi. Aynı başlık ile arama yaparsanız, sorunuzla ilgili birçok örnek bulacaksınız.

erdotsc · 12 Eylül 2012

Evet haklısınız. Tüm konuları inceledim fakat bir türlü sonuca ulaşamadım.

erdotsc · 13 Eylül 2012

Arkadaşlar sorunu halen çözemedim. İlgili örnekler üzerinden yapıyorum ama bir türlü işler hale getiremedim. Yardımınızı rica ederim.

Korhan Ayhan · 13 Eylül 2012

Merhaba,

Makronuzun yaptığı işlemleri adım adım açıklarsanız alternatif kodlar için yardımcı olabiliriz.

erdotsc · 13 Eylül 2012

Ekteki klasörde bulunan text dosyasının içeriğini parçalara ayırmaya yarıyor.

Örneğin;

%_N_1000_MPF
..
..
M30

ise 1000.MPF olarak MPF klasörünün içerisine atıyor.

%_N_L1000_SPF
..
..
M17

ise L1000.SPF olarak SPF klasörünün içerisine atıyor.

erdotsc · 17 Eylül 2012

Merhaba arkadaşlar,

Sorunu çözebilmiş değilim, lütfen yardımlarınızı esirgemeyin.

erdotsc · 17 Eylül 2012

Şöyle bir kod uygulayabilirmiyiz acaba.

Kod:

Option Explicit

Public Enum SORT_BY
    Sort_by_None
    Sort_by_Name
    Sort_by_Path
    Sort_by_Size
    Sort_by_Last_Access
    Sort_by_Last_Modyfy
    Sort_by_Date_Create
End Enum

Public Enum SORT_ORDER
    Sort_Order_Ascending
    Sort_Order_Descending
End Enum

Public Type FILEINFO
    strFilename As String
    strPath As String
    lngSize As Long
    dmtLastAccess As Date
    dmtLastModify As Date
    dmtDateCreate As Date
End Type

Public Sub Test()
    Dim objFileSearch As clsFileSearch
    Dim lngIndex As Long
   
    Set objFileSearch = New clsFileSearch
    With objFileSearch
        .CaseSenstiv = True
        .Extension = "*.xls"
        .FolderPath = "D:\"
        .SearchLike = "Test*"
        .SubFolders = True
        If .Execute(Sort_by_Size, Sort_Order_Descending) > 0 Then
            For lngIndex = 1 To .FileCount
                With .Files(lngIndex)
                    Debug.Print .strFilename, .lngSize
                End With
            Next
        End If
    End With
    Set objFileSearch = Nothing
End Sub

erdotsc · 19 Eylül 2012

Konu güncelliğini koruyor arkadaşlar.

Korhan Ayhan · 19 Eylül 2012

Merhaba,

Eklediğiniz dosyayı açamıyorum. Rardan çıkarırken hata veriyor.

halit3 · 19 Eylül 2012

Aslında kodların daha tam olarak ne yaptığını anlıyamadım. çünkü veri alınacak dosyalar yok.

Bu dosyadaki kodları denermisiniz.

erdotsc · 19 Eylül 2012

Merhabalar,

@Halit3, @Korhan Ayhan

Yaptığınız örnek kodu denedim ve sonuç vermedi.

İlk sayfada Teilen.zip adlı ekte gerekli dosyalar mevcut.

1002A1.F dosyasını herhangibir metin editöründe açabilirsiniz.

Teilen klasörünün içeriği;

Teilen >> NC_Programs >> Files_MPF >> Files_SPF ve parçalara ayrılacak olan text (uzantısı mühim değil.)
mevcuttur.

Makronun amacı ise;

%_N_1000_MPF ile başlayıp M30 ile biten metin bütününü kalıp olarak alıp Files_MPF klasörüne 1000.SPF isimli text dosyası oluşturuyor.

%_N_L1000_SPF ile başlayıp M17 ile biten metin bütününü kalıp olarak alıp Files_SPF klasörüne L1000.SPF isimli text dosyası oluşturuyor.

Bu şekilde text dosyasının içerisinde 100 adet üzerinde text dosyasını saniyeler içerisinde ayırabiliyor. El ile yapmaya kalktığımda 1 saatten fazla zaman alıyor.

İnternet üzerinde Text File Splitter isimli bir program buldum. Program gayet güzel çalışıyor fakat oluşturduğu dosya isimleri 1000.SPF olarak çıkarmak yerine %_N_1000_SPF olarak çıkarttığından aynı şekilde zaman israfına neden olmaktadır.

Korhan Ayhan · 19 Eylül 2012

Merhaba,

Ben eklediğiniz dosyaları açamıyorum. Hata veriyor. Bu sebeple yapmak istediğiniz işlemi inceleyemedim.

erdotsc · 19 Eylül 2012

Klasörü tekrar ZIP'ledim.

Tüm dosyaları metin editörü ile açabilirsiniz. (.F, .SPF)

Files_MPF ve Files_SPF klasörü içinde ayrılmış dosyalar mevcut.

halit3 · 19 Eylül 2012

Bu kod sizin kodunuzun aynısını yapıyor.

Kod:

Sub teilen_program()
Klasor = ActiveWorkbook.Path & "\NC_Programs\"
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files
sPath = ActiveWorkbook.Path
Open Dosya For Input As #1    'Datei in Speicher lesen
Do While Not EOF(1)               'Schleife starten bis End of file erreicht
test = LOF(1)
Line Input #1, daten      'Zeilenweise einlesen
ze = ze + 1         'Durchlaeufe Zaehlen
'Einlesen der Daten
'Einlesen der SPF
If Right(daten, 3) = "SPF" _
And Left(daten, 1) = "%" Then
sp = 5
Do While Not Mid(daten, sp, 1) = Chr(95) And sp <= Len(daten)
sp = sp + 1
Loop
programname = Mid(daten, 5, sp - 5)
spf = spf + 1
'Datei erstellen
Open sPath & "\NC_Programs\Files_SPF\" & programname & ".SPF" For Output As #2
Do While Not EOF(1)         'Schleife starten bis End of file erreicht
Print #2, daten
Line Input #1, daten      'Zeilenweise einlesen
ze = ze + 1
If Right(daten, 3) = "M17" Then
Print #2, daten
'ElseIf Right(daten, 3) = "RET" Then
'Print #2, daten
Exit Do
End If
Loop
Close #2    'neue Datei schließen
End If
'Einlesen der MPF
If Right(daten, 3) = "MPF" _
And Left(daten, 1) = "%" Then
sp = 5
Do While Not Mid(daten, sp, 1) = Chr(95) And sp <= Len(daten)
sp = sp + 1
Loop
programname = Mid(daten, 5, sp - 5)
mpf = mpf + 1
'Datei erstellen
Open sPath & "\NC_Programs\Files_MPF\" & programname & ".SPF" For Output As #2
Do While Not EOF(1)         'Schleife starten bis End of file erreicht
Print #2, daten
Line Input #1, daten      'Zeilenweise einlesen
ze = ze + 1
If Right(daten, 3) = "M30" Then
Print #2, daten
Exit Do
End If
Loop
Close #2 'neue Datei schließen
End If
Loop
'Datei zum einlesen schließen
Close #1
Next
MsgBox ("Einlesen erfolgreich. " & spf & " Unterprogramme verarbeitet " & mpf & " Hauptprogramme verarbeitet")
End Sub

erdotsc · 20 Eylül 2012

@Halit3

Çok teşekkür ederim, eline sağlık. Makro sorunsuz bir şekilde çalışıyor.

İlgilenen zaman ayıran herkese müteşekkirim.

halit3 · 20 Eylül 2012

erdotsc' Alıntı:
@Halit3

Çok teşekkür ederim, eline sağlık. Makro sorunsuz bir şekilde çalışıyor.

İlgilenen zaman ayıran herkese müteşekkirim.

İyi çalışmalar

Application.FileSearch Sorunu

erdotsc

Ekli dosyalar

hamitcan

Uzman

erdotsc

erdotsc

Korhan Ayhan

Administrator

erdotsc

Ekli dosyalar

erdotsc

erdotsc

erdotsc

Korhan Ayhan

Administrator

halit3

Uzman

Ekli dosyalar

erdotsc

Korhan Ayhan

Administrator

erdotsc

Ekli dosyalar

halit3

Uzman

erdotsc

halit3

Uzman