سليم حاصبيا

ممكن توضح المطلوب قليلاٌ(بلغة الاكسل) ما هو معيار تكرار الارقام (احيانا 13 و ثم 21 و من بعدها 14 الخ.)

ربما ينفع هذا الماكرو Sub copy_format() Range("A1").Copy Selection.PasteSpecial Paste:=xlPasteFormats End Sub

أخي أحب ان الفت انتباهك الى ان معادلتك تعطي النتيجة الصحيحة فقط اذا كان هناك التسلسل في العامود A تصاعدياً يمكن تلافي هذا الشيء باستخدام Countif لتصبح المعادلة : =IF(COUNTIF($B$2:$B$150,$E3)=0,"",INDEX($A$2:$A$150,MAX(IF($B$2:$B$150=$E3,ROW($B$3:$B$150)-ROW($B$3)+1,""))))

بعد إذن أخي زيزو (لعل العامود لا يحتوي ارقاماً) "Crtl + Shift + Enter" =INDEX($A$2:$A$150,MAX(IF($B$2:$B$150=$E3,ROW($B$3:$B$150)-ROW($B$3)+1,"")))

رفض الجهاز التعامل مع الملف لكني اخترت لك هذه المعادلة انسخ هذه المعادلة الى الخلية F5 ,واسحب نزولاً =IF(NOT(ISNUMBER(SEARCH("TOTAL",C5))),"",(SUM($D$5:D5)/2)-SUM($F$4:F4))

وجدت لك الحل في هذا الملف hide_similar_columns.rar

جرب هذا الماكرو Sub Iza7a() Dim my_rg As Range Dim i, r As Integer Set my_rg = ActiveSheet.Range("h3:k21").SpecialCells(2) For i = 1 To my_rg.Areas.Count r = my_rg.Areas(i).Cells(1).Row my_rg.Areas(i).Copy Range("b" & r).PasteSpecial xlPasteValues my_rg.Areas(i).Clear Next End Sub

يلزمك هذه المعادلة =SUMPRODUCT(INDIRECT("'"&A6&"'!$C$6:$C$12"),--(INDIRECT("'"&A6&"'!$b$6:$b$12")="ذكر"))

اين الملف

انسخ هذه المعادلة الى الخلية O3 واسحب نزولا =COUNT($B3:$M3)*$C7-SUM($B3:$M3)

اي خلية تقصد من العامود B الذي يتحوي على اكثر من مليون خلية

جرب هذه المعادلة =SUM(INDIRECT("'"&A6&"'!$C$6:$C$15"))

بارك الله بك و جزاك الله خيراً اخي ياسر ولكن عندي تساؤل لماذا لم تستعمل الحلقة For Nxet Private Sub CommandButton1_Click() Sheets(1).Activate lrow = Range("d" & Rows.Count).End(xlUp).Row + 1 Range("d" & lrow).Value = ComboBox1.Value For i = 1 To 6 Range("d" & lrow).Offset(0, i).Value = Controls("TextBox" & i).Value Controls("TextBox" & i).Value = "" Next End Sub

يمكنك الاستعانة بهذا الملف كنموذج WORKING_DAYS.rar

هناك معادلة ابسط قليلاً لكنها لا تعطي نتائج جيدة: مثلاً الارقام D2=1 C2=5 B2=3 تعطينا True بينما في الحقيقة False =AVERAGE($B2:$N2)=$B2 الافضل هذه المعادلة =SUMPRODUCT(--(AVERAGE($B2:$N2)=$B2:$N2))=COUNT($B2:$N2)

ارفع الملف للمعالجة و معرفة الخطأ

استبدل الفاصلة "," بفاصلة منقوطة ";" في المعادلة أو العكس(حسب اعدادات الجهاز عندك ) لتصبح هكذا =SUMIF($F$7:$F$500;$F$7;$F$7:$F$500)-(SUMPRODUCT(--($F$7:F8=F8);--($H$7:H8<>"")))

انسخ هذه المعادلة الى الخلية E7 واسحب نزولاً انها تعطيك ما تبقى من كل كود او توماتيك (بعد كتابة التاريخ)في الخانة المناسبة =SUMIF($F$7:$F$500,$F$7,$F$7:$F$500)-(SUMPRODUCT(--($F$7:F7=F7),--($H$7:H7<>"")))

عذراً اخي زيزو لم انتبه الى هذه النقطة لذلك قمت بالتعديل على الكود كما يلي: Option Explicit Sub Extract_Data2() Dim Source_Sh As Worksheet Dim Target_Sh As Worksheet Dim lr1, lr2 As Long Dim R, R1, m As Long Dim My_Rg, Found_rg As Range With Application .EnableEvents = False .ScreenUpdating = False End With Set Source_Sh = Sheets("السجل الكلي"): Set Target_Sh = Sheets("السجل المطلوب") lr1 = Application.Max(Source_Sh.Range("c:c")) + 8 Set My_Rg = Source_Sh.Range("e8:e" & lr1) Set Found_rg = My_Rg.Find(What:=Target_Sh.Range("q2"), lookat:=xlWhole) If Found_rg Is Nothing Then MsgBox "No Data to Transfere": GoTo 1 R = Found_rg.Row Do Set Found_rg = My_Rg.FindNext(Found_rg): R1 = Found_rg.Row If m < R1 Then m = R1 If R1 = R Then Exit Do Loop '============================== With Target_Sh .Range("d9:q10000").ClearContents .Cells(9, "d").Resize(m - R + 1).Value = Source_Sh.Cells(R, "d").Resize(m - R + 1).Value .Cells(9, "e").Resize(m - R + 1, 13).Value = Source_Sh.Cells(9, "f").Resize(m - R + 1, 13).Value End With 1: With Application .EnableEvents = True .ScreenUpdating = True End With End Sub

بعد اذن اخي زيزو و زيادة في اثراء الموضوع هذا الكود Option Explicit Sub Extract_Data() Dim Source_Sh As Worksheet Dim Target_Sh As Worksheet Dim lr1, lr2 As Long Dim R, R1, x As Long Dim My_Rg, Found_rg As Range With Application .EnableEvents = False .ScreenUpdating = False End With Set Source_Sh = Sheets("السجل الكلي"): Set Target_Sh = Sheets("السجل المطلوب") Target_Sh.Range("d9:q10000").ClearContents lr1 = Application.Max(Source_Sh.Range("c:c")) + 8 Set My_Rg = Source_Sh.Range("e8:e" & lr1) Set Found_rg = My_Rg.Find(What:=Target_Sh.Range("q2"), lookat:=xlWhole) If Not Found_rg Is Nothing Then: R = Found_rg.Row Target_Sh.Cells(x + 9, 4).Resize(, 15).Value = Source_Sh.Cells(R, 4).Resize(, 15).Value Do x = x + 1 Set Found_rg = My_Rg.FindNext(Found_rg): R1 = Found_rg.Row Target_Sh.Cells(x + 9, 4).Resize(, 15).Value = Source_Sh.Cells(R1, 4).Resize(, 15).Value If R1 = R Then Exit Do Loop Target_Sh.Cells(x + 9, 1).EntireRow.Delete Target_Sh.Cells(9, 4).Select With Application .EnableEvents = True .ScreenUpdating = True End With End Sub

انظر الى مشاركتي الاخيرة حول هذا الموضوع(قبل مشاركة الاخ محمد صالح) هناك مرفق (بعنوان No_writing In BB.rar يمكنك تنزيله)

حبث انك حملت صورة ولا احد بتعامل مع الصور بالمعادلات ارفق لك مثالاً كيف تجد ما تريده Salim_Search.rar

اخي زيزو الكود الذي رفعته يعمل بشكل ممتاز في حال كان تسلسل رقم الكرت (كل 30 صف) فقط و في حال الزيادة او النقصان تختلط الامور عدا عن ذلك الكود يعيد نفسة في كل مرة يتغير التحديد دون جدوى ونحن بحاجة اليه مرة واحدة فالافضل استعمال دالة Find حتى نجد الكلمة المناسية ونضع بجانبها اسم الصفحة و اظن ان الحدث SelectionChange لا ضرورة له لان الكود يجب ان يعمل مرة واحدة عند تنشيط الصفحة فقط وليس عند اي تغيير في تحديد اي خلية من العامود السادس مما يثقل الملف بشكل ملحوظ

انا سبقتك الى ذلك بهذا الكود عسى ان ينال الاعجاب Option Explicit Private Sub Workbook_SheetActivate(ByVal Sh As Object) find_row End Sub '============================================================= Sub find_row() Dim my_sh As Worksheet Dim rg_to_find As Range Dim search_word As String Dim r, r1 As Integer search_word = "رقم الكرت" Set my_sh = ActiveSheet Set rg_to_find = my_sh.Range("e:e").Find(search_word, lookat:=xlWhole) If Not rg_to_find Is Nothing Then r1 = rg_to_find.Row: Cells(r1, "f") = my_sh.Name Do Until r1 = r Set rg_to_find = my_sh.Range("e:e").FindNext(after:=rg_to_find) r = rg_to_find.Row Cells(r, "f") = my_sh.Name Loop End Sub

اخي ياسر لا اعرف اذا كنت اطلعت على الملف يشكل جيد او لا لان كل شيت تحتوي على اكثر من كرت بينهم تسلسل 30