ياسر خليل أبو البراء

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

السلام عليكم ارفق ملف موضحاً فيه المطلوب أخي الكريم

الحمد لله أن تم المطلوب على خير تقبل تحياتي

تفضل أخي الكريم محمود التعديل التالي .. عله يفي بالغرض إن شاء الله Private Sub CommandButton6_Click() Dim ws As Worksheet Dim r As Range Set ws = Worksheets("ss") For Each x In ws.Range("A101:A" & ws.Cells(Rows.Count, 1).End(xlUp).Row) If x = ComboBox1.Text Then x = x.Row Exit For End If Next x Set r = ws.Cells(x, 1) r.Offset(0, 1) = TextBox3.Text r.Offset(0, 2) = TextBox4.Text r.Offset(0, 3) = TextBox5.Text r.Offset(0, 5) = TextBox6.Text r.Offset(0, 6) = TextBox7.Text If CheckBox1.Value = True Then r.Offset(0, 4) = True If CheckBox2.Value = True Then r.Offset(0, 4) = False End Sub

قصدت حذف النطاق وليس مسح محتوياته ...

الحمد لله الذي بنعمته تتم الصالحات تقبل تحياتي

طيب ممكن تعطيني مثال للخطأ الذي يحدث معك وفي أي سطر يحدث الخطأ لأستطيع مساعدتك .. وهل تقصد بالإخفاء أن الورقة غير مرئية أم أن الورقة تكون غير نشطة وورقة أخرى هي النشطة؟

أخي الكريم المفترض أن تقوم بتثبيت نطاق البيانات بوضع علامة الدولار ..لاحظ السطر التالي =IFERROR(VLOOKUP(A3,فبراير!2:1194,2,FALSE),"not") قم بتثبيت النطاق بهذا الشكل =IFERROR(VLOOKUP(A3,فبراير!$2:$1194,2,FALSE),"not")

أخي الحبيب سليم جرب حذف النطاق A5:C6 ولاحظ النتائج ..

وعليكم السلام أخي الكريم الخطأ الموجود يعني أن العنصر غير موجود في ورقة البحث #N/A لذا يمكن تغيير المعادلة بهذا الشكل لتجنب الخطأ ضع المعادلة التالية في الخلية D3 ثم قم بسحبها لأسفل .. =IFERROR(VLOOKUP(A3,فبراير!$A$2:$B$2000,2,FALSE),"")

ما هو الإجراء المطلوب تعديله لديك في الملف؟ حدد الإجراء وما هو المطلوب عمله وسأحاول إن شاء الله الإطلاع عليه في أقرب وقت

في الأكواد الموجودة راجعها وأشر لورقة العمل قبل النطاق Range أو Cells بهذا الشكل نفترض أنك قمت بتعيين ورقة العمل ss في المتغير المسمى ws وكان لديك هذا السطر Range("A1").Value="Test" فقم بوضع المتغير المسمى ws والذي يشير لورقة العمل المعنية بهذا الشكل قبل السطر السابق ws.Range("A1").Value="Test"

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

السلام عليكم أخي الكريم محمود استبدل الكود الموجود في زر الأمر CommandButton8 بهذا الكود Private Sub CommandButton8_Click() Dim ws As Worksheet Set ws = Worksheets("ss") For Each x In ws.Range("A100:A" & ws.Cells(Rows.Count, 1).End(xlUp).Row) If x = ComboBox1.Text Then x = x.Row Exit For End If Next x m = MsgBox("سيتم حذف هذه العلاوة؟هل انت متأكد من اجراء هذه العملية", vbYesNo) If m = vbYes Then ws.Rows(x).Delete MsgBox "برجاء التأكد من حذف اى علاوة تاريخها اكبر من التى ستقوم بادخالها حتى لا يضر النتائج" Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox4.Value = "" Me.TextBox5.Value = "" Me.TextBox6.Value = "" Me.TextBox7.Value = "" CheckBox1.Value = False CheckBox2.Value = False Me.ComboBox1.Value = "" Else MsgBox "! لم يتم حذف العلاوة" End If End Sub

بارك الله فيك أخي العزيز زيزو وجزيت خيراً على مساعداتك القيمة في كافة الموضوعات أخي الكريم عبد الرحمن المشكلة لديك في اسم ورقة العمل البرمجي .. في ملفك الأخير ليست باسم Sheet1 وإنما باسم ورقة1 جرب الملف المرفق التالي فيه كود الأخ زيزو ASA1--2003.rar

تأكد من أن الحساب لديك في الملف تلقائي وليس يدوي

بارك الله فيك أخي الحبيب سليم بعد الإطلاع على ملفك وجدت أنك قمت بتحويل البيانات من أفقي لعمودي ، وليس كما هو مطلوب في عنوان الموضوع من عمودي لأفقي

السلام عليكم يرجى تغيير اسم الظهور للغة العربية أخي الكريم جرب الكود التالي .. ضع الكود في موديول عادي وبعد تنفيذ الكود ستجد النتائج في ورقة2 Sub Test() Dim coll As New Collection, arr, maxItem As Long, i As Long, j As Long, str1 As String, v1, v2 arr = Sheets("Sheet1").Range("A1:C" & Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row).Value For i = 1 To UBound(arr, 1) str1 = CStr(arr(i, 1)) On Error Resume Next coll.Add Key:=str1, Item:=New Collection On Error GoTo 0 If coll(str1).Count = 0 Then coll(str1).Add str1 For j = 2 To UBound(arr, 2) If Len(arr(i, j)) Then coll(str1).Add CStr(arr(i, j)) Next j Next i For Each v1 In coll If v1.Count > maxItem Then maxItem = v1.Count Next v1 ReDim arr(1 To coll.Count, 1 To maxItem) i = 0 For Each v1 In coll i = i + 1 j = 0 For Each v2 In v1 j = j + 1 arr(i, j) = v2 Next v2 Next v1 For j = 3 To maxItem - 2 Step 2 arr(1, j + 1) = "الشهر" arr(1, j + 2) = "الراتب" Next j Sheets("Sheet2").Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr End Sub

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

وجزيت خيراً بمثل ما دعوت لي أخي الكريم تقبل تحياتي

احذف كلمة Sheet1 من هذا السطر (ستجدها مرتين) ..ومعها النقطة التي تليها أيضاً وكذلك احذفها من آخر سطر بالنقطة التي تليها أو ... استبدل كلمة Sheet1 بكلمة ورقة1

وعليكم السلام أخي الكريم عبد الرحمن جرب الكود التالي عله يفي الغرض Sub Test() Dim arr As Variant Dim str As String Dim i As Long arr = Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row).Value For i = LBound(arr, 1) To UBound(arr, 1) str = arr(i, 1) arr(i, 1) = Trim(Split(Mid(str, InStrRev(str, "\") + 1), ".")(0)) Next i Sheet1.Range("B1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr End Sub

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

وجزيت خيراً بمثل ما دعوت لي أخي العزيز والحمد لله أن تم المطلوب على خير

لم تذكر شكل النتائج المتوقعة كما طلبت منك عموماً جرب الكود بهذا الشكل Option Explicit Sub ImportDataFromClosedWBs_YasserKhalil() Dim strFolder As String Dim strFile As String Dim wbk As Workbook Dim sh As Worksheet Dim lr As Long Dim i As Long With Application .ScreenUpdating = False .Calculation = xlManual .DisplayAlerts = False .AskToUpdateLinks = False End With strFolder = ThisWorkbook.Path & "\الفواتير\" strFile = Dir(strFolder & "*.xls*") Do While strFile <> "" Set wbk = Workbooks.Open(strFolder & strFile) Set sh = wbk.Worksheets(1) With ThisWorkbook.Worksheets(1) i = 7 lr = IIf(.Cells(Rows.Count, 1).End(xlUp).Row < 3, 3, .Cells(Rows.Count, 1).End(xlUp).Row + 1) .Range("G" & lr).Resize(1, 2).Value = sh.Range("A2").Resize(1, 2).Value .Range("I" & lr).Value = sh.Range("F1").Value .Range("J" & lr).Value = sh.Range("F2").Value .Range("K" & lr).Value = sh.Range("F3").Value .Range("O" & lr).Value = sh.Range("B2").Value Do .Range("A" & lr).Resize(1, 6).Value = sh.Range("A" & i).Resize(1, 6).Value lr = IIf(.Cells(Rows.Count, 1).End(xlUp).Row < 3, 3, .Cells(Rows.Count, 1).End(xlUp).Row + 1) i = i + 1 Loop Until sh.Range("A" & i).Value = "" End With wbk.Close False strFile = Dir Loop With Application .AskToUpdateLinks = True .DisplayAlerts = True .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub