الـعيدروس

السلام عليكم بالامكان استخدام كودك بالشكل التالي Sub MAS() Application.ScreenUpdating = False Set sh1 = Sheets("1") Set sh2 = Sheets("2") Dim x As Integer ' x= تمشي بشكل عمودي ينتقل من صف الي اخر ولكن بنفس العمود Dim y As Integer ' y= تمشي بشكل افقي بعد الانتهاء من العمود الاول تنتقل للعمود الثاني بشكل صفوف Dim z As Integer 'هي القيمة العددية التي تتناقص For a = 1 To 16 fa = sh1.Range("a" & a) sn = 0 For b = 1 To 26 fb = sh1.Range("a" & b) For c = 1 To 26 fc = sh1.Range("a" & c) For d = 1 To 26 fd = sh1.Range("a" & d) sn = sn + 1 ww = fa & fb & fc & fd sh2.Cells(sn, a) = "http://www." & ww & ".com" Next d Next c Next b Next a '------------------------------------------------------------------------------------------------------ sh2.Activate Application.ScreenUpdating = True End Sub وهذا الكود في حدث الورقة المسماه 2 بحيث عند النقر دبل كليك على اي خليه ينشاء Hyperlink في الخليه Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, ActiveSheet.UsedRange) Is Nothing Then With ActiveSheet .Hyperlinks.Add Anchor:=Target, Address:=Target, SubAddress:="", TextToDisplay:=CStr(Target.Text) End With End If End Sub او عند النقر مباشره على اي خليه ينشاء Hyperlink في الخليه Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, ActiveSheet.UsedRange) Is Nothing Then With ActiveSheet .Hyperlinks.Add Anchor:=Target, Address:=Target, SubAddress:="", TextToDisplay:=CStr(Target.Text) End With End If End Sub

السلام عليكم هكذا بيكون Private Sub Workbook_SheetActivate(ByVal Sh As Object) Ap_A False With Sh.UsedRange .Columns.EntireColumn.AutoFit '' الاعمدة .Rows.EntireRow.AutoFit '' الصفوف .Borders.Color = 1 '' البوردر With .Font .Name = "Times New Roman" '' اسم الخط .Size = 10 '' حجم الخط End With End With Ap_A True End Sub Private Function Ap_A(Bn As Boolean) With Application .Calculation = IIf(Bn, -4105, -4135) .ScreenUpdating = Bn .EnableEvents = Not Bn End With End Function

بالامكان ذلك في حدث Thisworkbook مباشره عند دخولك الصفحه Private Sub Workbook_SheetActivate(ByVal Sh As Object) Sh.UsedRange.Columns.EntireColumn.AutoFit End Sub

استخدم الكود التالي Public Sub Ali_Clm() On Error Resume Next ActiveSheet.UsedRange.Columns.EntireColumn.AutoFit On Error GoTo 0 End Sub

السلام عليكم حبذا تحط بيانات وهميه في الاوراق والى ذلك حط نتائج التي تريدها في ورقة الخزينة كي تتضح الصورة لمن اراد المشاركه

جميع بيانات الملفات لشهر واحد حسب ملفاتك الحاليه ؟ اضفت في بعض الملفات اشهر وهميه بمعنى بيانات لـ 6 اشهر جرب الكود التالي حط الملفات بنفس فولدر الملف الذي به الكود Sub Ali_Tran_Fil() Dim Pth As String Dim F_il As String Dim S_Nm As String Dim My_Vlu() As Variant Dim Lr, Lrr, R, Dy, Ar, Az, Ar_O, ii, rr, pp, Cr Dim Date_M As Date Dim O_Wp As Workbook Dim ws As Worksheet Dim Sh As Worksheet Dim Mi_A As Worksheet Dim sht As Worksheet Set Mi_A = Sheets(1) De_Sht CStr(Mi_A.Name) Apc_Ali False '-------------------------------------------------------------------- Pth = ThisWorkbook.Path & "\" '' مسار الملفات بنفس مسار الملف الحالي '-------------------------------------------------------------------- F_il = Dir(Pth & "*.xlsx") '' xlsx صيغة ملفات الاكسل التي سيتم جلب بياناتها '-------------------------------------------------------------------- ReDim Preserve My_Vlu(1 To 10000, 1 To 6) '-------------------------------------------------------------------- Do While F_il <> "" If F_il <> ThisWorkbook.Name Then S_Nm = Pth & F_il Set O_Wp = Workbooks.Open(S_Nm) Set ws = O_Wp.Sheets(1) Lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row For R = 2 To Lr I = I + 1 My_Vlu(I, 1) = ws.Cells(R, 3) My_Vlu(I, 2) = ws.Cells(R, 1) My_Vlu(I, 3) = ws.Cells(R, 2) My_Vlu(I, 4) = ws.Cells(R, 6) My_Vlu(I, 5) = ws.Cells(R, 7) My_Vlu(I, 6) = Split(F_il, ".")(0) Next R O_Wp.Close False F_il = Dir End If Loop '-------------------------------------------------------------------- Mi_A.Range("A2").Resize(UBound(My_Vlu, 1), UBound(My_Vlu, 2)) = My_Vlu '-------------------------------------------------------------------- Mi_A.Sort.SortFields.Add Key:=Mi_A.Range("D2", Mi_A.Range("D2").End(xlDown)), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With Mi_A.Sort .SetRange Mi_A.Range("A2:F" & Mi_A.Range("A1").End(xlDown).Row) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With '-------------------------------------------------------------------- With CreateObject("scripting.dictionary") For ii = LBound(My_Vlu, 1) To UBound(My_Vlu, 1) If My_Vlu(ii, 1) <> "" Then If IsDate(My_Vlu(ii, 4)) Then Date_M = My_Vlu(ii, 4) Dy = .Item(Month(Date_M)) End If End If Next ii Ar = Split(Join(.Keys, ","), ",") End With '-------------------------------------------------------------------- For rr = LBound(Ar) To UBound(Ar) If IsError(Evaluate("'" & Ar(rr) & "'!A1")) Then Set Sh = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)) With Sh .Name = CStr(Ar(rr)) Az = Array("رقم العميل", "العدد", "الصنف", "التاريخ", "السعر", "إسم الملف") With .Range("A1") .Offset(0, 0).Resize(1, UBound(Az) + 1) = Az End With .Columns(1).ColumnWidth = 29.29 .Columns(2).ColumnWidth = 8.43 .Columns(3).ColumnWidth = 15 .Columns(4).ColumnWidth = 16.14 .Columns(5).ColumnWidth = 8.43 .Columns(6).ColumnWidth = 8.43 End With End If Next rr '-------------------------------------------------------------------- Ar_O = Mi_A.Range("A1").CurrentRegion.Value For Each sht In Sheets If Not sht.Index = 1 Then For pp = 1 To UBound(Ar_O, 1) If IsDate(Ar_O(pp, 4)) Then If Trim(Month(Ar_O(pp, 4))) = Trim(sht.Name) Then With sht Lrr = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row .Cells(Lrr, 1) = Ar_O(pp, 1) .Cells(Lrr, 2) = Ar_O(pp, 2) .Cells(Lrr, 3) = Ar_O(pp, 3) .Cells(Lrr, 4) = Ar_O(pp, 4) .Cells(Lrr, 5) = Ar_O(pp, 5) .Cells(Lrr, 6) = Ar_O(pp, 6) End With End If End If Next pp End If Next sht '**** Sh_S '**** '\\\\\\\\ Cr = Split(Mi_A.UsedRange.Address, "$")(4) Mi_A.Range("A2:F" & IIf(Cr = 1, 2, Cr)).ClearContents '//////// Apc_Ali True '************************************ Set O_Wp = Nothing: Set ws = Nothing Set Sh = Nothing: Set Mi_A = Nothing Set sht = Nothing: Erase My_Vlu End Sub Private Sub B_Set(Sh_N()) Dim T_m Dim I, J '---------------------------------- Apc_Ali False For I = LBound(Sh_N) To UBound(Sh_N) For J = I To UBound(Sh_N) If Sh_N(I) > Sh_N(J) Then T_m = Sh_N(I) Sh_N(I) = Sh_N(J) Sh_N(J) = T_m End If Next J Next I Apc_Ali True '---------------------------------- End Sub Private Sub Sh_S() Dim Sht_a As Worksheet Dim My_Sh() Dim I '------------------------------------------ Apc_Ali False ReDim My_Sh(ThisWorkbook.Worksheets.Count) I = LBound(My_Sh) For Each Sht_a In ThisWorkbook.Worksheets My_Sh(I) = Sht_a.Name I = I + 1 Next Sht_a '----------- B_Set My_Sh '----------- For I = LBound(My_Sh) + 1 To UBound(My_Sh) If Sheets(My_Sh(I)).Index <> 1 Then Worksheets(My_Sh(I)).Move After:=Worksheets(ThisWorkbook.Worksheets.Count) End If Next I Apc_Ali True '------------------------------------------ End Sub Public Function De_Sht(ByVal Nm_S As String) Dim Sh_D As Worksheet ''------------------------------------ For Each Sh_D In Worksheets Application.DisplayAlerts = False If Sh_D.Name <> Nm_S Then Sh_D.Delete Application.DisplayAlerts = True Next Sh_D ''------------------------------------ Set Sh_D = Nothing End Function Public Function Apc_Ali(Bll As Boolean) ''------------------------------------ With Application .Calculation = IIf(Bll, -4105, -4135) .ScreenUpdating = Bll .EnableEvents = Not Bll End With ''------------------------------------ End Function والمرفقات الملف وبه الكود new_Ali.rar

السلام عليكم الاستاذ الحبيب احمد زمان حفظك الله ورعاك نورت المنتدى نفتقدكم كثيراً يامن تعلمنا على يدهم تقبل تحياتي وشكري

السلام عليكم المرفق الاول الشرح والاخر الملف شرح_5.rar البحث بين تاريخين_A.rar

الاخ الحبيب ياسر فتحي اشكرك على كلماتك الطيبه واخلاقك العاليه تقبل تحياتي وشكري

اذهب الى الدالة التاليه في الكود Private Function Ch_Month(Mn As String) Dim Mm& Dim Tn$, X$ For Mm = 1 To 12 Tn = MonthName(Mm) If Tn = Trim(Mn) Then Mm = Mm - 1 X = MonthName(Mm) Exit For End If Next If Mm Then Ch_Month = X End Function واستبدلها بهذا التعديل Private Function Ch_Month(Mn As String) Dim Im, Tn, X Dim Ar On Error GoTo 1 Ar = Array("يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") For Im = 0 To UBound(Ar) Tn = Ar(Im) If Tn = Trim(Mn) Then Im = Im - 1: X = Ar(Im): Exit For Next Im Ch_Month = X 1 End Function اضن السبب تسمية الاشهر لديك ربما تكون بالفرنسية في الـ VBA

هل يعني زبط معاك ام هناك لخبطه ؟

جرب هذا التعديل Private Function Ali(Ln As Long, Vl, Bl As String, Bln As Boolean) Dim Shet As Worksheet Dim Do_Ali Dim Ar() As Variant Dim iCnt& Dim X, A Dim XX As Integer On Error Resume Next Set Shet = Sheets("Report") Set Do_Ali = CreateObject("Scripting.Dictionary") With Application .ScreenUpdating = False .EnableEvents = True DoEvents With Shet Lr = .Cells(.Rows.Count, 2).End(xlUp).Row Ar = .Range("A2:F" & Lr).Value: A = Bl For R = LBound(Ar, 1) To UBound(Ar, 1) If Ar(R, 3) = A Then If Not Bln Then If Vl = 3 Then ZZ = Ar(R, 2): ZZZ = Ar(R - 1, 2) If ZZZ <> ZZ Then X = X + 1 End If End If If Vl = 4 Or Vl = 2 Then X = X + Ar(R, 6): XX = XX + 1 End If End If If Do_Ali.exists(Ar(R, Ln)) Then Do_Ali.Item(Ar(R, Ln)) = Do_Ali.Item(Ar(R, Ln)) + 1 Else Do_Ali.Add Ar(R, Ln), 1 End If End If Next Ali = IIf(Vl = 1, Do_Ali.Count, IIf(Vl = 2, XX, X)) End With .ScreenUpdating = True .EnableEvents = False End With Erase Ar Set Do_Ali = Nothing Set Shet = Nothing End Function Sub Ali_Count() Dim Sh As Worksheet Dim Sht As Worksheet Dim R, Rr, Cll, Lrr Set Sh = Sheets("Rank") Set Sht = Sheets("Report") With Sh Lrr = Sht.Cells(Rows.Count, 2).End(xlUp).Row Sht.Sort.SortFields.Add Key:=Sht.Range("A2:A" & Lrr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With Sht.Sort .SetRange Sht.Range("A1:F" & Lrr) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Rr = 10: Cll = 13 For R = Rr To Cll If .Cells(R, 2) <> "" Then .Cells(R, 4) = Ali(1, 4, .Cells(R, 2), False) .Cells(R, 9) = Ali(1, 3, .Cells(R, 2), False) .Cells(R, 14) = Ali(1, 2, .Cells(R, 2), False) .Cells(R, 19) = Ali(1, 1, .Cells(R, 2), True) End If Next End With MsgBox "Greetings with Engineer / Yasser Fathi Al-Banna " End Sub

تفضل Sub Ali_Tv() Dim r1, r2, r3, r4, r5, r6 Dim i1, i2, i3, i4 Dim Rw Dim n1, n2, n3, n4, n5, n6 Dim t1, t2, t3, t4 Dim X, XX, Xl_Ali, Bm, Ibn1, Ibn11 Dim Fil_Nm As Integer Dim Pth As String Dim Sh1 As Worksheet, Sh2 As Worksheet Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2") '**************************** Const Sr = 8: Const Bnk = 10 Const Tol = 13: Const Cus = 7 Const Ky = 2: Const Nm = 27 '======================================================================================= With Sh1 Ibn = IIf(InStr(1, CStr(.[B6]), ".") <> 0, Val(.[B6] * 100), CStr(.[B6])) r1 = CStr(.[B5]): r2 = CStr(.[E5]): r3 = Val(Ibn) r4 = CStr(.[B7]): r5 = CStr(.[B8]): r6 = CStr(.[D8]) If Len(r1) < Bnk Then i1 = String((Bnk - Len(r1)), "0") & r1 Else i1 = r1 End If If Len(r2) < Ky Then i2 = String((Ky - Len(r2)), "0") & r2 Else i2 = r2 End If If Len(r3) < Tol Then i3 = String((Tol - Len(r3)), "0") & r3 Else i3 = r3 End If If Len(r4) < Cus Then i4 = String((Cus - Len(r4)), "0") & r4 Else i4 = r4 End If X = "*" & String(Sr, "0") & i1 & i2 & i3 & i4 & r5 & r6 & String(14, " ") & "0" '======================================================================================= For Rw = 13 To .[A12].End(xlDown).Row If Not .Cells(Rw, 1) = Empty Then '======================================================================================= Ibn1 = IIf(InStr(1, CStr(.Cells(Rw, 6)), ".") <> 0, Val(.Cells(Rw, 6) * 100), CStr(.Cells(Rw, 6))) n1 = CStr(.Cells(Rw, 4)): n2 = CStr(.Cells(Rw, 5)): n3 = Val(Ibn1) n4 = CStr(UCase(.Cells(Rw, 2))): n5 = CStr(UCase(.Cells(Rw, 3))) If Len(n1) < Bnk Then t1 = String((Bnk - Len(n1)), "0") & n1 Else t1 = n1 End If If Len(n2) < Ky Then t2 = String((Ky - Len(n2)), "0") & n2 Else t2 = n2 End If If (Len(n3) < Tol) Then t3 = String((Tol - Len(n3)), "0") & n3 Else t3 = n3 End If If (Len(n4 & " ") + Len(n5)) < Nm Then t4 = n4 & " " & n5 & String((Nm - (Len(n4 & " ") + Len(n5))), " ") Else t4 = n4 & " " & n5 End If XX = XX & "*" & String(Sr, "0") & t1 & t2 & t3 & t4 & "1" & vbNewLine '======================================================================================= End If Next Rw End With '--------------------------- Xl_Ali = X & vbNewLine & XX & Chr(26) '------------------------------------------------------------------------------ Bm = Split(Xl_Ali, vbNewLine): Sh2.Range("A1").Resize(UBound(Bm)) = Application.Transpose(Bm) _ : Sh2.Range("A1").Offset(UBound(Bm) - 1) = Chr(26) '--------------------------- Fil_Nm = FreeFile '------------------------------------------------------------------------------ Pth = ThisWorkbook.Path & "\" & "Disq" & " " & r5 & r6 & ".txt" '------------------------------------------------------------------------------ Open Pth For Output As #Fil_Nm '--------------------------- Print #Fil_Nm, Xl_Ali '--------------------------- Close #Fil_Nm '--------------------------- Set Sh1 = Nothing: Set Sh2 = Nothing End Sub

اذا كان في جزء من الكود غير متوافق مع اللغه عندك سيظهر رسالة خطاء وحسب ماشفت بالفيديو لم يظهر اي رسائل خطاء عموما انسخ السطر التالي والصقه واتبع الطريقة في الفيديو المرفق Debug.Print Ali_C(CStr(.Cells(I, 22)), CStr(.Cells(I, 3)), 1) وقبل تنفيذ الكود اضغط "Ctrl+G" وانت في واجة الفيجول ثم نفذ الكود بالضغط على علامة المربع التي في واجهة الفيجول وشوف هل ستظهر النتائج في مربع الايميديت شرح_4.rar

لاحظ السطر الثاني في مثالك 9 اصفار لماذا والذي شرحت انت ان يكون العدد الكلي للرصيد هو الصحيح يكون هكذا ارجوا توضيح النتائج المرجوه لان هذا الذي لخبط دماغي شرحك غير النتائج

تفضل Ali_cnnd.rar

Sub MakeFolders() Dim Rng As Range Dim maxRows, maxCols, r, c As Integer Dim Pth As String Set Rng = Selection maxRows = Rng.Rows.Count maxCols = Rng.Columns.Count Pth = "C:\Users\abdu\Desktop\" '' تحط مسار حفظ المجلدات هنا For c = 1 To maxCols r = 1 On Error Resume Next Do While r <= maxRows If Len(Dir(Pth & Rng(r, c), vbDirectory)) = 0 Then MkDir (Pth & Rng(r, c)) End If r = r + 1 Loop Next c On Error GoTo 0 End Sub هكذا لتحديد مسار Sub MakeFolders() Dim Rng As Range Dim maxRows, maxCols, r, c As Integer Dim Ali_F As Object Dim Pth As String Set Rng = Selection maxRows = Rng.Rows.Count maxCols = Rng.Columns.Count Pth = "C:\Users\abdu\Desktop\" '' تحط مسار حفظ المجلدات هنا For c = 1 To maxCols r = 1 On Error Resume Next Do While r <= maxRows Set Ali_F = CreateObject("Scripting.FileSystemObject") If Not Ali_F.FolderExists(Pth & Rng(r, c)) Then Ali_F.CreateFolder (Pth & Rng(r, c)) End If r = r + 1 Loop Next c On Error GoTo 0 Set Ali_F = Nothing End Sub واذا لم تعمل معك اداة MkDir جرب هذا الكود بطريقة اخرى

MonthName الدالة السابقه لإرجاع اسم الشهر حسب تسلسله مثال : اذا اعطيناها MonthName(1) ستخرج لنا اسم اول شهر في السنه الذي هو "يناير"

السلام عليكم الاخ الفاضل كريم ابو الفتوح الحمد لله ان عمل معك الاخ والاستاذ الحبيب ياسر خليل اشكرك على كلماتك الطيبه ومرورك العطر ان شاء الله نكون عند حسن الظن تقبلو تحياتي وشكري

شرح تنصيب البرنامج والعمل عليه فيديو و 3 صور خطوات لإخراج ملف فيديو شرح_3.rar الاخ الحبيب ياسر خليل ابو البراء ان شاء الله سيتم شرح الدوال وارفاقها في المشاركه السابقه

اخي ابو عبدالملك نصب البرنامج الذي في المرفقات البرنامج لتسجيل الشاشه فيديو وافتح الملف الذي في المشاركه ع الرابط http://www.officena.net/ib/topic/64859-تعديل-كود-الأستاذ-ياسر/?do=findComment&comment=423789 وارفق الفيديو هنا بعد ضغطه Recor_Scren.rar

في هذا الكود Private Function Ch_Month(Mn As String) Dim Mm& Dim Tn$, X$ For Mm = 1 To 12 Tn = MonthName(Mm) If Tn = Trim(Mn) Then Mm = Mm - 1 X = MonthName(Mm) Exit For End If Next If Mm Then Ch_Month = X End Function دالة vba.MonthName شوف وش اسمها عندك

Sub Ali_Tv() Dim r1, r2, r3, r4, r5, r6 Dim i1, i2, i3, i4 Dim Rw Dim n1, n2, n3, n4, n5, n6 Dim t1, t2, t3, t4 Dim X, XX, Xl_Ali, Bm Dim Fil_Nm As Integer Dim Pth As String Dim Sh1 As Worksheet, Sh2 As Worksheet Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2") '**************************** Const Sr = 8: Const Bnk = 10 Const Tol = 13: Const Cus = 7 Const Ky = 2: Const Nm = 27 '======================================================================================= With Sh1 r1 = CStr(.[B5]): r2 = CStr(.[E5]): r3 = CStr(.[B6]) r3 = IIf(InStr(1, r3, ".") <> 0, Replace(r3, ".", ""), r3) r4 = CStr(.[B7]): r5 = CStr(.[B8]): r6 = CStr(.[D8]) If Len(r1) < Bnk Then i1 = String((Bnk - Len(r1)), "0") & r1 Else i1 = r1 End If If Len(r2) < Ky Then i2 = String((Ky - Len(r2)), "0") & r2 Else i2 = r2 End If If Len(r3) < Tol Then i3 = String((Tol - Len(r3)), "0") & r3 Else i3 = r3 End If If Len(r4) < Cus Then i4 = String((Cus - Len(r4)), "0") & r4 Else i4 = r4 End If X = "*" & String(Sr, "0") & i1 & i2 & i3 & i4 & r5 & r6 & String(14, " ") & "0" '======================================================================================= For Rw = 13 To .[A12].End(xlDown).Row If Not .Cells(Rw, 1) = Empty Then '======================================================================================= n1 = CStr(.Cells(Rw, 4)): n2 = CStr(.Cells(Rw, 5)): n3 = CStr(.Cells(Rw, 6)) n3 = IIf(InStr(1, n3, ".") <> 0, Replace(n3, ".", ""), n3) n4 = CStr(UCase(.Cells(Rw, 2))): n5 = CStr(UCase(.Cells(Rw, 3))) If Len(n1) < Bnk Then t1 = String((Bnk - Len(n1)), "0") & n1 Else t1 = n1 End If If Len(n2) < Ky Then t2 = String((Ky - Len(n2)), "0") & n2 Else t2 = n2 End If n3 = Format(n3, "0.00"): n3 = Replace(n3, ".", "") If Len(n3) < Tol Then t3 = String((Tol - Len(n3)), "0") & n3 Else t3 = n3 End If If (Len(n4 & " ") + Len(n5)) < Nm Then t4 = n4 & " " & n5 & String((Nm - (Len(n4 & " ") + Len(n5))), " ") Else t4 = n4 & " " & n5 End If XX = XX & "*" & String(Sr, "0") & t1 & t2 & t3 & t4 & "1" & vbNewLine '======================================================================================= End If Next Rw End With '--------------------------- Xl_Ali = X & vbNewLine & XX '------------------------------------------------------------------------------ Bm = Split(Xl_Ali, vbNewLine): Sh2.Range("A1").Resize(UBound(Bm)) = Application.Transpose(Bm) '--------------------------- Fil_Nm = FreeFile '------------------------------------------------------------------------------ Pth = ThisWorkbook.Path & "\" & "Disq" & " " & r5 & r6 & ".txt" '------------------------------------------------------------------------------ Open Pth For Output As #Fil_Nm '--------------------------- Print #Fil_Nm, Xl_Ali '--------------------------- Close #Fil_Nm '--------------------------- Set Sh1 = Nothing: Set Sh2 = Nothing End Sub جرب الكود هذا ان شاء الله يعمل بالشكل الذي تريد ملف التكست سيحفظه بنفس فولدر ملف الاكسل تحياتي

ربما يكون هذا السبب جرب عدل على الكود

السلام عليكم السطر التالي cel.SpecialCells(xlCellTypeConstants).ClearContents استبدله بهذا cel.Delete Shift:=xlUp