مساعدة فى كود vba

[((( folks )))]

السلام عليكم ورحمة الله وبركاته

عند فتح الفورم بالأوفيس 2003 لا تظهر المشكلة ولكن عنده فتحه بإصدار أعلى تظهر المشكلة 

Private Sub FrstChnge(combo1, combo2)
Dim val As String
Dim ARY As Variant

val = combo1.Value
combo2.Clear
If val = "" Then Exit Sub
val = ThisWorkbook.Path & "\" & val & "\Ser"
With Application.FileSearch
    .NewSearch
    .LookIn = val
    .SearchSubFolders = False
    .FileType = msoFileTypeExcelWorkbooks
    If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
            Namey = .FoundFiles(i)
            For nn = Len(Namey) To 1 Step -1
                If Mid(Namey, nn, 1) = "\" Then
                    Namey = Right(Namey, Len(Namey) - nn)
                    Namey = Left(Namey, Len(Namey) - 4)
                End If
                Next nn
            combo2.AddItem Namey
        Next i
    End If
End With

End Sub

 

تم تعديل أكتوبر 31 بواسطه ((( folks )))

[عبدالله بشير عبدالله]

وعليكم السلام ورحمة الله وبركاته

لو ارفقت لنا ملفك لاختصرت الوقت او ارفقت الجملة التى بها خطأ لسهلت لنا الامر

يدون ملف محاولات قد تصيب وقد تخطئ

ريما السبب من جملة  FILESEARCH والتي اعتقد انها غير متوافقة مع الاصدارات بعد 2003 ( غير متاكد منها)

سنفترض ان الامر منها فيكون تعديل الكود كالتالى

Private Sub FrstChnge(combo1 As ComboBox, combo2 As ComboBox)
    Dim val As String
    Dim Namey As String
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    
    combo2.Clear
    
    If combo1.Value = "" Then
        MsgBox "الرجاء اختيار شيت من القائمة", vbExclamation
        Exit Sub
    End If
    
    val = ThisWorkbook.Path & "\" & combo1.Value & "\Ser"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If fso.FolderExists(val) Then
        Set folder = fso.GetFolder(val)
        For Each file In folder.Files
            If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Then
                Namey = file.Name
                Namey = Left(Namey, Len(Namey) - 5) ' إزالة الامتداد .xlsx
                combo2.AddItem Namey
            End If
        Next file
    Else
        MsgBox "المجلد غير موجود: " & val, vbExclamation
    End If
    
    Set fso = Nothing
    Set folder = Nothing
    Set file = Nothing
End Sub

او جرب الكود التالى 

Private Sub FrstChnge(combo1 As ComboBox, combo2 As ComboBox)
    Dim val As String
    Dim filePath As String
    Dim fileName As String

    val = combo1.Value
    combo2.Clear
    If val = "" Then Exit Sub

    filePath = ThisWorkbook.Path & "\" & val & "\Ser\"
    fileName = Dir(filePath & "*.xls*")

    Do While fileName <> ""
        combo2.AddItem Left(fileName, Len(fileName) - 4)
        fileName = Dir
    Loop
End Sub

اذا لم بعمل ارفق ملفك 

وفقك الله

تم تعديل نوفمبر 1 بواسطه عبدالله بشير عبدالله

[((( folks )))]

6 ساعات مضت, عبدالله بشير عبدالله said:

Private Sub FrstChnge(combo1 As ComboBox, combo2 As ComboBox)
    Dim val As String
    Dim filePath As String
    Dim fileName As String

    val = combo1.Value
    combo2.Clear
    If val = "" Then Exit Sub

    filePath = ThisWorkbook.Path & "\" & val & "\Ser\"
    fileName = Dir(filePath & "*.xls*")

    Do While fileName <> ""
        combo2.AddItem Left(fileName, Len(fileName) - 4)
        fileName = Dir
    Loop
End Sub

بارك الله فيك يا استاذى ونفع بك وبعلمك الأمة وجعل عملك هذا فى ميزان حسناتك يوم القيامة

[((( folks )))]

اقتباس

ريما السبب من جملة  FILESEARCH والتي اعتقد انها غير متوافقة مع الاصدارات بعد 2003 ( غير متاكد منها) 

قول حضرتك صحيح 100% بعد إذنك حضرتك تتكرم بتعديل بباقى الجمل لأنها تتعارض مع إصدار 2003

Private Sub TamamUpdate()
Dim val, x As String

ComboBox28.Clear
If OptionButton1.Value = True Then
    val = ThisWorkbook.Path & "\Tamam\ONE\"
ElseIf OptionButton2.Value = True Then
    val = ThisWorkbook.Path & "\Tamam\ALL\"
End If
With Application.FileSearch
    .NewSearch
    .LookIn = val
    .SearchSubFolders = False
    .FileType = msoFileTypeExcelWorkbooks
    If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
            Namey = .FoundFiles(i)
            For nn = Len(Namey) To 1 Step -1
                If Mid(Namey, nn, 1) = "\" Then
                    Namey = Right(Namey, Len(Namey) - nn)
                    Namey = Left(Namey, Len(Namey) - 4)
                End If
            Next nn
            ComboBox28.AddItem Namey            
        Next i
    End If
End With

End Sub

 

Private Sub Removedfrm()

    val = ThisWorkbook.Path & "\" & ShNm & "\Ser"
    FlNo = 0
    With Application.FileSearch
        .NewSearch
        .LookIn = val
        .SearchSubFolders = False
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
            Namey = .FoundFiles(i)
            For nn = Len(Namey) To 1 Step -1
                If Mid(Namey, nn, 1) = "\" Then
                    Namey = Right(Namey, Len(Namey) - nn)
                End If
                Next nn
            LwF(i) = Namey
            Next i
    End If
    FlNo = .FoundFiles.Count
End With

For ShNo = 2 To ShNoE
    Tmam_Wbk.Sheets(ShNo).Select
    RTmpE = CLng(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row) - 1
    ShNm = ActiveSheet.Name
    For Rw = 2 To RTmpE
        If InStr(ActiveSheet.Cells(Rw, 1).Value, "إجمالى") Then GoTo Nxt30
        Kat = ActiveSheet.Cells(Rw, 1).Value
        All_Wbk.Activate
        

        RAllE = 0
        For i = 2 To LRow
        If ActiveSheet.Cells(i, 6).Value = ComboBox28.Value Then
        If ActiveSheet.Cells(i, 1).Value = ShNm Then
        If ActiveSheet.Cells(i, 3).Value = Kat Then
        RAllE = RAllE + 1
        End If
        End If
        End If
        Next i
       Tmam_Wbk.Activate
        ActiveSheet.Cells(Rw, 5).Value = RAllE
Nxt30:
    Next Rw
Next ShNo
End Sub

عذراً ليس بالإمكان رفع الملف لأنه خاص بالمؤسسة

تم تعديل نوفمبر 2 بواسطه ((( folks )))