نسخ البلديات من الجدول إلى ملف خارجي

[dah_med]

السلام عليكم

إخواني في المنتدى

المطلوب هو نسج الجدول حسب البلديات (العمود h ) إلى ملف خارجي classeur كل بلدية في ملف خارجي (classeur) لوحدها

مستخدمي البلديات.rar

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

السلام عليكم

 

في الملف كود قد عملته سابقا لاحدهم قد يناسبك

 

المرفق 2003

مستخدمي المدارس الابتدائية++.rar

[dah_med]

وعليكم السلام

أخي عبد الله جزاك الله كل خير

فقط عند فتح الملفات المنسوخة يظهر خطأ عند الفتح شاهد الصورة بالمرفق

كما أن الملفات تظهر من اليسار إلى اليمين حبذا ولو تكون من اليمن إلى اليسار

 

 

error.rar

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

السلام عليكم

 

شاهد المرفق

مع ملاحظة ان الملفات الناتجة من الكود ملفات اوفيس 2003 بشكل ثابت

حتى لو استبدل ملف الكود الى اوفيس احدث

 

المرفق 2003

مستخدمي المدارس الابتدائية++.rar

[dah_med]

أخي عبد الله

جزاك الله كل خير

بقية مسالة إتجاه الملف المستخرج

حبذا لو يكون من اليمين إلى اليسار

[dah_med]

للرفع رفع الله شأنكم

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

السلام عليكم

 

استبدل هذا الكود

Sub kh_AddSheetsInNewBook()
Dim Sh As Worksheet
Dim i As Long, Last As Long
Dim NamSheet As String, txt As String
'============================
On Error Resume Next
With Feuil1
    .AutoFilterMode = False
    Last = .Cells(.Rows.Count, "B").End(xlUp).Row
    If Last < 10 Then GoTo kh_ExT
    Set ColumnFilter = Range("H9:H" & Last)
    Set Rng = Range("B9:AZ" & Last)
End With
'''''''''''''''''''''''
kh_SetNewPath
'''''''''''''''''''''''
kh_Application False
'''''''''''''''''''''''
With ColumnFilter
    For i = 2 To .Rows.Count
        NamSheet = Trim(.Cells(i, 1))
        If Len(NamSheet) Then
            NamSheet = kh_Replace(NamSheet)
            '''''''''''''''''''''
            If InStr(1, "#" & txt, "#" & NamSheet & "#", vbTextCompare) = 0 Then
                txt = txt & NamSheet & "#"
                Set Sh = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
                Sh.Name = NamSheet
                Sh.DisplayRightToLeft = True
                '''''''''''''''''''''''
                kh_PastRngInNewBook Sh, CStr(.Cells(i, 1))
                '''''''''''''''''''''''
            End If
        End If
    Next
End With
'''''''''''''''''''''''
kh_ExT:
With Rng.Worksheet
    .Activate
    .AutoFilterMode = False
End With
'''''''''''''''''''''''
kh_Application True
'''''''''''''''''''''''
Set Sh = Nothing
Set Rng = Nothing
Set ColumnFilter = Nothing
On Error GoTo 0
End Sub

تحياتي

[dah_med]

السلام عليكم

أخي عبد الله الكود لا يعمل تماما

ينشأ مجلد فارغ

[dah_med]

للرفع رفع الله شأنكم