الـعيدروس

السلام عليكم ترحيل من فورمة إلي فورمة_A.rar

الاستاذ الحبيب جمال عبدالسميع داول مركبة جميله بارك الله فيك وهذه بالاكواد Sub Ali_Txt() Dim Sv, T_v For Each ii In [B2:B100] If Not IsEmpty(ii) Then With ii Sv = Split(.Value, " "): T_v = UBound(Sv) Range(Cells(.Row, .Column + 1), Cells(.Row, .Column + 1 + T_v)).Value = Sv End With End If Next End Sub

اذهب الى السطر التالي من الكود If Mid(Fn.Name, InStrRev(Fn.Name, ".") + 1) = "xls" Then واستبدله بهذا If Mid(Fn.Name, InStrRev(Fn.Name, ".") + 1) = "xlsx" Then حسب الصورة المرفقه لديك امتداد الملفات هيا "xlsx" تحياتي

عدل المسار الذي في الكود Dir_w = "C:\Users\gh\Desktop\delet" الى مسار ملفات الاكسل بمعنى تكون في مجلد واحد شاهد الشرح في المرفق لمعرفة مسار المجلد شرح.rar

Public Sub Ali_Copy() Dim F, Fn, Nm, wb As Workbook Dim Dir_w, Chk$ '********************************** ' مسار مجلد ملفات الإكسل Dir_w = "C:\Users\gh\Desktop\delet" '********************************** Th = ThisWorkbook.Name C = 1 Set F = CreateObject("Scripting.FileSystemObject") Set Fn = F.GetFolder(Dir_w) For Each Fn In Fn.Files If Mid(Fn.Name, InStrRev(Fn.Name, ".") + 1) = "xls" Then Chk = Dir_w & Application.PathSeparator & Fn.Name If Wr_open(Chk) = False Then On Error Resume Next Application.ScreenUpdating = False Application.DisplayAlerts = False Workbooks.Open Chk Application.ScreenUpdating = True Application.DisplayAlerts = True On Error GoTo 0 End If End If Next Fn For wr = 1 To Workbooks.Count If Workbooks(wr).Name <> Th Then Workbooks(wr).Worksheets(1).Range("A2:A100").Copy Workbooks(Th).Activate Cells(1, C) = Workbooks(wr).Name Cells(2, C).PasteSpecial xlPasteValues C = C + 1 End If Next End Sub Function Wr_open(Wn As String) As Boolean Dim Wbook As Workbook On Error Resume Next Set Wbook = Workbooks(Wn) Wr_open = Not Wbook Is Nothing On Error GoTo 0 End Function

السلام عليكم شاهد المرفق ثثث_1.rar

الاخ الفاضل ابو حنين اضغط الملف بااحد برامج الضغط Winrar أو winzip ثم ارفقه

الاخت الفاضله ام عبدالله لاعليكى تعدد الحلول تنير وتثري الاعضاء بارك الله فيكى وملفك حقيقه اعطى تحديث للذاكرة دالة CEILING تأدي الغرض بإختصار جزاك الله كل خير تحياتي وشكري للجميع

مالتغير الذي تريده بزيادة يوم او تغير الى التاريخ الحاليا وعند اضافة عمود اعلم ان موقع عمود التاريخ بيتغير ؟ وعمل الكود بيتلخبط حاول اضافة الاعمدة الذي تريدها على حسب ان تكون الاعمدة في الورقة ثابته لاتغير وبعدها نعدل بالكود ============ ولو توضح المعطيات بشكل كامل والنتائج الذي تريدها بيكون افضل كي نقراء ماتريد بشكل اوضح ============ جرب المرفق تحياتي ar_d1.rar

السلام عليكم جرب هذه المعادله =IF(B2-INT(B2)<0.5;INT(B2)+0.5;INT(B2)+1)

طلبك واضح ارجو ارفاق ملف للعمل عليه فضلاً عن هدر جهد ووقت في ما لاتصبو اليه تحياتي

السلام عليكم شاهد المرفق احدث اي تغير في احد خلايا عمود A بتاريخ اخر ar_d.rar

بعد اذن الاساتذه الافاضل هل هكذا تريد جرب هذا التعديل الكود الصقه في حدث الورقة Public D Public Rw Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [A:A]) Is Nothing Then If IsDate(Target) And Target <> D Then Rw = Target.Row Macro1 Rw End If End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, [A:A]) Is Nothing Then D = CDate(Target) End Sub Sub Macro1(N) Dim I As Integer, C 'For I = 4 To [A65000].End(xlUp).Row For C = 19 To 2 Step -1 Cells(N, C).Value = Cells(N, C).Offset(0, -1).Value Next 'Next End Sub

السلام عليكم جزاك الله كل خير استاذ عبدالله ولإثراء الموضوع هذه طريقة اخرى الكود في حدث الفورم Private Sub UserForm_Activate() Dim Nm As Variant Dim Nm_Cl As New Collection Dim Tr_Nm As Variant Nm = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Value On Error Resume Next For Each Tr_Nm In Nm Nm_Cl.Add Tr_Nm, Tr_Nm Next Tr_Nm On Error GoTo 0 For Tr_Nm = 1 To Nm_Cl.Count ComboBox1.AddItem Nm_Cl(Tr_Nm) Next Tr_Nm End Sub

الملف فيه مشكله وليس الكود انشاء ملف جديد كمل تفضل الاستاذ بن عليه وسوف يعمل معك ان شاء الله

السلام عليكم If Target.Column = 5 And Target.Row => 7 Then

تنقل للخليه المجاورة تحت أي شرط ؟

اخي الكريم حسام الحمداني طلبك غير واضح --------------- المربعات الزرقاء عند الادخال او عند التعديل ؟ الحقول الزرقاء الموضوحه في الصورة اين موقعها في الورقة

الاخ الفاضل عادل ابو زيد ملف قيم به معلومات تفيد الكثير بارك الله فيك وجزاك خير الجزاء تقبل مروري

السلام عليكم شاهد المرفقات هذه كودك بعد الاختصار والتعديل Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, ActiveSheet.Rows(2)) Is Nothing Then If ActiveSheet.AutoFilterMode Then Target.Interior.Color = RGB(255, 153, 0) Target.ClearContents ActiveSheet.Cells.AutoFilter End If Cancel = True End If End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [A2:I2]) Is Nothing Then Cc = Target.Column If Target.Value = "" Then ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=Cc Else Tr = Target If IsDate(Tr) Then D_a = DateSerial(Year(Tr), Month(Tr), Day(Tr)) Id = D_a Tr = Format$(Id, "yyyy/mm") End If ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=Cc, Criteria1:=Tr List_Ali Feuil2.Range("$A$3") Exit Sub End If End If End Sub Private Sub List_Ali(Rng As Range) Dim Ri As Range Dim Ar& Application.EnableEvents = 0 Application.ScreenUpdating = 0 With Sheets("Feuil3") .UsedRange.Clear Set Ri = Rng.CurrentRegion.SpecialCells(xlCellTypeVisible) A = Cells(Rows.Count, 1).End(xlUp).Row Set Ri = Range(Ri.Offset(2, 0), Cells(A, 9)) Ri.Copy .Range("A1") Set Ri = .Range("A1").CurrentRegion With UserForm1.ListBox1 .ColumnCount = 9 .List = Ri.Value End With UserForm1.Show .UsedRange.Clear End With Application.EnableEvents = 1 Application.ScreenUpdating = 1 End Sub شرح_2.rar rrr_2.rar

السلام عليكم بيكون الكود بعد التعديل كالتالي انسخ والصقه في ملفك والمرفق توضيح عمل الكود عندي Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, ActiveSheet.Rows(2)) Is Nothing Then If ActiveSheet.AutoFilterMode Then ActiveSheet.Cells.AutoFilter Target.Interior.Color = RGB(255, 153, 0) End If Cancel = True End If End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Range("f2").Value = "" Then ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=6 Else ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=6, Criteria1:=Range("f2") End If If Range("g2").Value = "" Then ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=7 Else ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=7, Criteria1:=Range("g2") End If If Range("h2").Value = "" Then ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=8 Else ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=8, Criteria1:=Range("h2") End If If Range("i2").Value = "" Then ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=9 Else ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=9, Criteria1:=Range("i2") End If If Range("e2").Value = "" Then ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=5 Else ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=5, Criteria1:=Range("e2") End If If Range("D2").Value = "" Then ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=4 Else Dim D_a As Date Dim Id&, Tr Tr = ActiveSheet.Range("D2") D_a = DateSerial(Year(Tr), Month(Tr), Day(Tr)) Id = D_a ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=4, Criteria1:=Format$(Id, "yyyy/mm") Target.Interior.Color = 255 End If End Sub تطبيق شرح.rar

اخي الفاضل اذا لم يظهر معاك اي يوزرات في قائمة تغير كبينة مستخدم = لاتوجد اي إدخالات في الورقة إدخل يوزرات مستخدم واحد او اثنين وجرب برضه حاول تدخل يوزر مستخدم ثم جرب زر خروج مستخدم عموما جرب المرفق برنامج_مقهى_5-3.rar

سلمت الانامل يااستاذ عبدالله تقبل مروري يتصفح من الجوال <<-----

جرب هكذا Sub Print1() Dim i As Integer ActiveSheet.PageSetup.BlackAndWhite = True For i = Range("N2") To Range("O2") Range("N2") = i If i <= Range("N2") Then ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Next Range("N2").Select End Sub

الطريقة الوحيده هيا عن طريق كود وعملت لك كود يفي بالغرض في الموضوع السابق تحياتي