محمد هشام.

لايستجيب لانك للاسف قمت بنسخ ووضع الاكواد بطريقة خاطئة لقد تعمدت عدم رفع الملف جاهز لتتمكن انت بوضعها بغرض الاستفادة والتعلم وهدا هو هدفنا الاول ملاحظة : لقد لاحظت انك قمت بحدف الجداول السفلى في ورقة 10 لهدا تم استبدال نطاق المعادلات من With Range("H9:H44") .Formula = "=SUMIFS('" & b & "'!" & V1.Address & ",'" & b & "'!" & V2.Address & ","">=""&$E$5,'" & b & "'!" & V2.Address & ",""<=""&$G$5,'" & b & "'!" & V3.Address & ",C9)" .Value = .Value الى اخر صف عليه بيانات في عمود الصنف With Range("H9:H" & lastrow) .Formula = "=SUMIFS('" & b & "'!" & v1.Address & ",'" & b & "'!" & V2.Address & ","">=""&$E$5,'" & b & "'!" & V2.Address & ",""<=""&$G$5,'" & b & "'!" & V3.Address & ",C9)" .Value = .Value تفضل اخي برنامج المستودع 2.xlsb

1) هل تقصد باسوورد محرر الاكواد او باسوورد الدخول للملف الطريقة التي سميتها بغير الشرعية يجب تحديدها اولا

الحل انك تقوم بتعديل اسماء التكست بوكس 35 و 36 انت لما بتعدل بتنسخ قيمة تيكست بوكس البحث حاول تغيير اسمها لاسم اخر واعادة تسمية التيكست بوكس 36 الا 35 بدون ما تنسى تغيير الاسماء داخل الاكواد

تفضل سيتم تنفيد الكود الخاص بكل ورقة عمل عند التغيير في احدى خلايا تاريخ البداية او النهاية سواءا في ورقة 4 او 10 في module جديد انسخ الاكواد التالية Sub test1() '********************************* تقرير الاصناف Dim Sh As Worksheet: Set Sh = Sheet4 Dim Sh1 As Worksheet: Set Sh1 = Sheet6 Dim Sh2 As Worksheet: Set Sh2 = Sheet8 b = Sh1.Name: C = Sh2.Name With Application .ScreenUpdating = False .Calculation = xlManual End With Set V1 = Sh1.Range("$H$9:$H$1000"): Set V4 = Sh2.Range("$H$9:$H$1000") Set V2 = Sh1.Range("$B$9:$B$1000"): Set V5 = Sh2.Range("$B$9:$B$1000") Set V3 = Sh1.Range("$E$9:$E$1000"): Set V6 = Sh1.Range("$E$9:$E$1000") With Range("G9:G" & Range("C" & Rows.Count).End(3).Row) .Formula = "=SUMIFS('" & b & "'!" & V1.Address & ",'" & b & "'!" & V2.Address & ","">=""&$F$7,'" & b & "'!" & V2.Address & ",""<=""&$I$7,'" & b & "'!" & V3.Address & ",C9)" .Value = .Value With Range("H9:H" & Range("C" & Rows.Count).End(3).Row) .Formula = "=SUMIFS('" & C & "'!" & V4.Address & ",'" & C & "'!" & V5.Address & ","">=""&$F$7,'" & C & "'!" & V5.Address & ",""<=""&$I$7,'" & C & "'!" & V6.Address & ",C9)" .Value = .Value End With End With With Application .ScreenUpdating = True .Calculation = xlAutomatic End With End Sub Sub test2() '************************ 'الجرد الشهري Dim MyRng As Range Dim Sh As Worksheet: Set Sh = Sheet10 Dim Sh1 As Worksheet: Set Sh1 = Sheet6 Dim Sh2 As Worksheet: Set Sh2 = Sheet8 b = Sh1.Name: C = Sh2.Name Set MyRng = Sh.Range("A9:M44") With Application .ScreenUpdating = False .Calculation = xlManual End With Set V1 = Sh1.Range("$H$9:$H$1000"): Set V4 = Sh2.Range("$H$9:$H$1000") Set V2 = Sh1.Range("$B$9:$B$1000"): Set V5 = Sh2.Range("$B$9:$B$1000") Set V3 = Sh1.Range("$E$9:$E$1000"): Set V6 = Sh1.Range("$E$9:$E$1000") With Range("H9:H44") .Formula = "=SUMIFS('" & b & "'!" & V1.Address & ",'" & b & "'!" & V2.Address & ","">=""&$E$5,'" & b & "'!" & V2.Address & ",""<=""&$G$5,'" & b & "'!" & V3.Address & ",C9)" .Value = .Value With Range("J9:J44") .Formula = "=SUMIFS('" & C & "'!" & V4.Address & ",'" & C & "'!" & V5.Address & ","">=""&$E$5,'" & C & "'!" & V5.Address & ",""<=""&$G$5,'" & C & "'!" & V6.Address & ",C9)" .Value = .Value End With End With MyRng.Replace 0, "", xlWhole With Application .ScreenUpdating = True .Calculation = xlAutomatic End With End Sub في حدث ورقة 4 Private Sub Worksheet_Change(ByVal Target As Range) Dim Lr As Long Application.ScreenUpdating = False Set V1 = Sheet4: Set V2 = Sheet10: Set V3 = Sheet11 Lr = V1.Range("C" & Rows.Count).End(xlUp).Row V2.Range("F9:F" & Lr).Value = V1.Range("F9:F" & Lr).Value V3.Range("F9:F" & Lr).Value = V1.Range("L9:L" & Lr).Value V3.Range("H9:H" & Lr).Value = V1.Range("O9:O" & Lr).Value If Intersect(Target, Range("F7:i7")) Is Nothing Then Exit Sub On Error Resume Next Application.EnableEvents = False Call test1 Application.EnableEvents = True On Error GoTo 0 Application.ScreenUpdating = True End Sub في حدث ورقة 10 Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Application.ScreenUpdating = False If Intersect(Target, Range("E5:G5")) Is Nothing Then Exit Sub Application.EnableEvents = False Call test2 Application.EnableEvents = True On Error GoTo 0 End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim Lr As Long Set V1 = Sheet4: Set V2 = Sheet10: Set V3 = Sheet11 Lr = V1.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row Application.ScreenUpdating = False V2.Range("F9:F" & Lr).Value = V1.Range("F9:F" & Lr).Value V3.Range("F9:F" & Lr).Value = V1.Range("L9:L" & Lr).Value V3.Range("H9:H" & Lr).Value = V1.Range("O9:O" & Lr).Value Application.ScreenUpdating = True End Sub

اولا مادا تقصد بالارتباط التشعبي وما دخله في نقل البيانات يكفي شرح طلبك فقط بدون اظافة اي اكواد ببساطة ممكن تكتب مثلا عمود رصيد البداية في شيت 4 يتم نسخ بياناته الى عمود الكمية شيت 10 عمود الرصيد الي هو عمود ( L ) شيت 4 الى عمود العدد الكلي شيت 11 عمود الرصيد الي هو اخر عمود يتم نسخه الى عمود التكلفة الشيت 11 ادا كان هدا هو طلبك ما هو شرط النسخ هل عند كل تغيير في ورقة 4 او بشرط اخر

العفو اخي يسعدنا اننا استطعنا مساعدتك بالتوفيق

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

وعليكم السلام ورحمة الله تعالى وبركاته عبد ادن الاخ @محي الدين ابو البشر اليك حل اخر Sub FindNational_ID() Dim WSdata As Worksheet, WSdest As Worksheet, i As Long Dim Sh1 As Variant, Sh2 As Variant Set WSdata = Feuil1 Application.ScreenUpdating = False Set WSdest = Workbooks.Open(ThisWorkbook.Path & "\شيت رقم2.xlsx").Sheets(1) Sh1 = WSdest.Range("c2", WSdest.Range("c" & Rows.Count).End(xlUp)).Value Sh2 = WSdata.Range("C2", WSdata.Range("C" & Rows.Count).End(xlUp)).Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(Sh2, 1) If Not .Exists(Sh2(i, 1)) Then .Add Sh2(i, 1), Nothing End If Next i For i = 1 To UBound(Sh1, 1) If .Exists(Sh1(i, 1)) Then WSdest.Range("F" & i + 1).Value = WSdata.Range("N" & i + 1).Value End If Next i End With Workbooks("شيت رقم2.xlsx").Close True Application.ScreenUpdating = True End Sub شيت رقم 1.xlsb

حاول تنظيم ملفك بشكل افضل مع التاكد من صحة البيانات على القوائم المنسدلة تفضل New Microsoft Excel Worksheet (2).XLSX

وعليكم السلام ورحمة الله تعالى وبركاته اثراءا للموضوع وبعد ادن الاستاد الكبير @ياسر خليل أبو البراء تفضل اخي يمكنك الابحار كما تشاء داخل مجلداتك وتعبئة جميع الملفات الموجودة داخل الفولدرات على الليست بوكس وفتحها مباشرة عند الظغط اليك الرابط التالي للمعاينة https://streamable.com/uv6f29 ملاحظة : لقد جعلت الكود افتراضي على الفولدرات الموجودة في نفس مسار الملف يمكنك تعديلها على حسب احتياجاتك داخل الكود التالي Private Sub UserForm_Initialize() ' مسار وجود الملف myPatch = Application.ThisWorkbook.Path ' قم بتحديد القرص الخاص بك 'myPatch = "D:\" Set MH = CreateObject("Scripting.FileSystemObject") Set dossier = MH.GetFolder(myPatch) Me.ListBox1.Clear: Me.ListBox2.Clear: Me.ListBox3.Clear Me.ListBox4.Clear: Me.ListBox5.Clear: Me.ListBox6.Clear n = 0 For Each d In dossier.SubFolders Me.ListBox1.AddItem d.Name Me.ListBox1.List(n, 1) = dossier.Path n = n + 1 Next Me.TextBox1 = dossier.Path listefichiers dossier.Path End Sub تعبئة الليست ياسماء الفولدرات 2.xlsm

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

وعليكم السلام ورحمة الله تعالى وبركاته اول مشكلة هي انك رافع الملف بدون الغاء باسوورد محرر الاكواد مع عدم ادراجه داخل المشاركة بحيث نظطر لكسره لمعرفة مكان الخطأ تفضل اخي استبدل كود الترحيل بالكود التالي Sub HARD() Dim WS1 As Worksheet Dim WS2 As Worksheet Dim Rng As Range Dim A, B, C, D As String Set WS1 = ThisWorkbook.Sheets("المبيعات") Set WS2 = ThisWorkbook.Sheets("ترحيل") Set Rng = WS1.Range("B8:E24") A = WS1.[E2]: B = WS1.[E3]: C = WS1.[B1]: D = WS1.Range("B2") If Application.WorksheetFunction.CountIf(WS2.Range("B:B"), WS1.[E2].Value) > 0 Then MsgBox "رقم الوثيقة موجود مسبقا", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub If Application.WorksheetFunction.CountA(WS1.Range("E8:E24")) = 0 Then Exit Sub Application.ScreenUpdating = False F = Rng For i = 1 To UBound(F) If Len(F(i, 4)) > 0 Then WS2.Range("b" & Rows.Count).End(xlUp).Offset(1).Resize(1, 4).Value _ = Array(A, B, C, D) On Error Resume Next ' Rng.SpecialCells(xlCellTypeConstants).ClearContents WS1.Range("B1,B2").Value = Empty On Error GoTo 0 With WS2.Range("A2:A" & WS2.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-1") End With End If Next Application.ScreenUpdating = True MsgBox "تم ترحيل البيانات بنجاح", vbInformation, "تعليمات " End Sub عرض تجربه1.xlsm

الغفو اخي يسعدني حقا انني استطعت مساعدتك تفضل لقد تم تصحيح الاكواد الدي قمت باظافتها انت على اخر ملف مرفوع على المنتدى وتفعيلها على ورقة 7 و8 شاشة الدخول مع صلاحيات 4.xlsb

لهدا سبق تدكيرك بضرورة انهاء تصميم ملفك حتى نتمكن من تحديد اسماء الشيتات والنطاقات المرغوب الاشتغال عليها على العموم اخي يمكننا العمل خطوة خطوة للوصول للنتيجة المطلوبة سوف نشتغل على اول شيت وهو ورقة 5 مع ترحيل البيانات الى ورقة 6 . يمكنك بعد دالك نسخ نفس الاكواد مع تغيير اسماء اوراق العمل فقط اول خطوة هتدخل على حدث ورقة 5 وتمسح جميع الاكواد السابقة وتقوم بتعويضها بالتالي تم انشاء كود الترحيل والطباعة مع بعض الاظافات التي من الممكن ان تساعدك على العمل على الملف بشكل افضل بالنسبة للاستدعاء طريقة وضعك للمعادلات بورقة الادخال لن تمكنك من استدعاء البيانات في نفس الموضع يمكنك انشاء ورقة خاصة بدالك او تعويض الصيغ بالاكواد *****ترحيل****** Private Sub cmdadd2_Click() Dim wsdata As Worksheet Dim wsdest As Worksheet Dim Rng1 As Range, Rng2 As Range Set wsdata = ThisWorkbook.Sheets("Sheet5") Set wsdest = ThisWorkbook.Sheets("Sheet6") Dim A, B, C, D, E, F, J, k, L, The_Date, N_invoice, The_Currency As String Set Rng1 = wsdata.Range("A9:G28") Set Rng2 = wsdata.Range("A32,C32,E32") The_Date = Date: N_invoice = wsdata.[F7]: The_Currency = "د" & "." & "إِ." A = wsdata.[A32]: B = wsdata.[A33]: C = wsdata.[A34] D = wsdata.[C32]: E = wsdata.[C33]: F = wsdata.[C34] J = wsdata.[E32]: k = wsdata.[E33]: L = wsdata.[E33] Arr = Array([B9], [C9], [D9], [E9], [F9], [G9], [A32], [C32], [E32]) For i = 0 To 8 If Arr(i) = Empty Then msg = MsgBox("يرجى ملء بيانات" & " " & Arr(i).Offset(-1, 0), vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "Admin") Arr(i).Select Exit Sub End If Next If Not IsNumeric(N_invoice) Or N_invoice = 0 Then MsgBox "المرجوا ادخال رقم الفاتورة", vbExclamation, "Admin": Exit Sub If Application.WorksheetFunction.CountIf(wsdest.Range("C:C"), wsdata.[F7].Value) > 0 Then MsgBox "رقم الفاتورة موجود مسبقا", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "Admin": Exit Sub msg = MsgBox("ترحيل البيانات ؟", vbYesNo + vbQuestion, "Admin") If msg = vbYes Then Application.ScreenUpdating = False col = Rng1 For i = 1 To UBound(col) If Len(col(i, 2)) > 0 Then wsdest.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(1, 17).Value _ = Array(The_Date, N_invoice, (col(i, 2)), (col(i, 3)), (col(i, 4)), (col(i, 5)), (col(i, 6)), The_Currency & (col(i, 7)), A, B, C, D, E, F, J, k, L) On Error Resume Next ' Union(Rng1, Rng2).SpecialCells(xlCellTypeConstants).ClearContents N_invoice.Value = N_invoice.Value + 1 With wsdest.Range("A9:A" & wsdest.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-8") wsdata.[F7].Value = wsdest.Range("C" & Rows.Count).End(xlUp).Value + 1 End With End If Next Call Add_border wsdata.Activate Application.ScreenUpdating = True msg = MsgBox("تم ترحيل البيانات بنجاح", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "Admin") End If End Sub *****فاتورة جديدة****** Private Sub CommandButton1_Click() Dim msg As VbMsgBoxResult Dim MyRng As Range Set wsdata = ThisWorkbook.Sheets("Sheet5") Set MyRng = wsdata.Range("A9:G28") msg = MsgBox("هل انت مناكد من افراغ البيانات ؟ ", vbYesNo + vbQuestion + vbDefaultButton2, "انتباه") If msg = vbYes Then On Error Resume Next Application.ScreenUpdating = False MyRng.SpecialCells(xlCellTypeConstants).ClearContents wsdata.Range("A32,C32,E32").Value = Empty On Error GoTo 0 End If End Sub Private Sub Worksheet_Activate() Set ws1 = ThisWorkbook.Sheets("Sheet5") Set ws2 = ThisWorkbook.Sheets("Sheet6") Application.ScreenUpdating = False On Error Resume Next If Len(ws2.Range("C9").Value) <> Empty Then ws1.[F7].Value = ws2.Range("C" & Rows.Count).End(xlUp).Value + 1 End If End Sub *****ترقيم عمود (A)****** Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False On Error Resume Next If Not Intersect(Target, Range("B9:B28")) Is Nothing Then Application.EnableEvents = False AddNumbering Application.EnableEvents = True End If On Error GoTo 0 End Sub Private Sub CmdPrint_Click() Print_invoice End Sub وفي module جديد انسخ الاكواد التالية Sub Print_invoice() ' طباعة Dim sh As Worksheet, i As Long Set sh = ActiveSheet If Application.WorksheetFunction.CountA(sh.Range("B9:B28")) = 0 Then msg = MsgBox("ليس هناك بيانات للطباعة", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "Admin") Exit Sub End If For i = 9 To 28 Application.ScreenUpdating = False If Cells(i, 1) = "" And Cells(i, 2) = "" Then Cells(i, 1).EntireRow.Hidden = True End If Next sh.PageSetup.PrintArea = "A1:G35" ActiveWindow.SelectedSheets.PrintOut Range("A9:A28").EntireRow.Hidden = False End Sub Sub AddNumbering() ' ترقيم Dim MyDest As Worksheet: Set MyDest = Sheet5 Dim F As Range, R As Range Set D = MyDest.Range("A9:A28") Set F = MyDest.Range("B9:B28") D.ClearContents For Each R In F If R.Value <> "" Then J = J + 1 R.Offset(0, -1).Value = Format(J, "0") End If Next End Sub Sub Add_border() ' تسطير البيانات Dim rng As Range, cell As Range Dim sh As Worksheet: Set sh = Sheet6 Application.ScreenUpdating = False sh.Activate dl = sh.Range("A:R").Find("*", , , , xlByRows, xlPrevious).Row 'Sh.Range("a9:R" & dl).Borders.LineStyle = xlNone sh.Range("A9:R1000").Borders.LineStyle = xlNone dc = sh.Cells(9, Columns.Count).End(xlToLeft).Column Set rng = sh.Range(Cells(9, 1), sh.Cells(dl, dc)) For Each cell In rng With cell .Borders.Weight = xlThin .Borders.ColorIndex = 5 End With Next cell End Sub شاشة الدخول مع صلاحيات 3.xlsb

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

نعم يمكنك اختصار الكود كالتالي لانه في الاصل المعادلة موجودة فقط يتم تحويلها الى قيم ويتم تحديثها عند كل تعديل في البيانات ' وضع المعادلة WSData.Range("P10:P" & DerLig).Formula = "=""(""& O10&"" / ""&N10&"")""" With WSData.Range("P10:P" & DerLig) End With

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

يمكنك استثناء اوراق العمل الاخرى داخل الكود بالطريقة التالية Sub CreateSheets() Dim mydata As Worksheet: Set mydata = ThisWorkbook.Sheets("Sheet1") Dim MyRng As Range, RngCopy As Range, Sh As Collection Dim cell As Range, DerLig As Long, ws As Worksheet Dim wsDest As Variant, s As String, SheetName As String Set MyRng = mydata.Range("C6:C" & mydata.Cells(mydata.Rows.Count, "C").End(xlUp).Row) Set Sh = New Collection With Application .ScreenUpdating = False .DisplayAlerts = False End With '*********' قم باظافةاسماء اوراق العمل الغير مرغوب حدفها من المصنف هنا************** SheetName = "Sheet1,Sheet2" '*********************************************************************************** Application.ScreenUpdating = False For Each ws In Worksheets If InStr(1, SheetName, ws.Name) = 0 Then Réf = Application.Match(ws.Name, arr, 0) If IsError(Réf) Then ws.Delete End If End If Next ws On Error Resume Next For Each cell In MyRng.Cells Sh.Add cell.Value, CStr(cell.Value) Next cell On Error GoTo 0 For Each wsDest In Sh s = wsDest Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsDest ActiveSheet.DisplayRightToLeft = True With mydata DerLig = .Cells(.Rows.Count, "C").End(xlUp).Row .Range("A5").AutoFilter field:=3, Criteria1:=wsDest Set RngCopy = .Range("A5:C" & DerLig) RngCopy.Copy Sheets(s).Range("A5") .Select .[A5].AutoFilter End With Next wsDest For Each wscopy In Worksheets If InStr(1, SheetName, wscopy.Name) = 0 Then Réf = Application.Match(wscopy.Name, arr, 0) If IsError(Réf) Then For i = 1 To 3 wscopy.Cells.EntireRow.AutoFit wscopy.Columns(i).ColumnWidth = mydata.Columns(i).ColumnWidth wscopy.Rows("5:5").RowHeight = mydata.Rows("5:5").RowHeight wscopy.Columns("B:B").ColumnWidth = 70 wscopy.Activate With ActiveWindow .SplitRow = 5 .SplitColumn = 0 .FreezePanes = True End With Next End If End If Next wscopy mydata.Activate With Application .ScreenUpdating = True .DisplayAlerts = True End With End Sub اسلاميات 3.xlsm

ربما قوانين المنتدى لا تسمح بدالك لضمان حقوق الملكية لصاحب الملف نعم اخي يمكنا فعل دالك بعض موافقة مشرفي المنتدى

وعليكم السلام ورحمة الله تعالى وبركاته Sub CreateSheets() Dim mydata As Worksheet: Set mydata = ThisWorkbook.Sheets("Sheet1") Dim MyRng As Range, RngCopy As Range, Sh As Collection Dim cell As Range, DerLig As Long Dim wsDest As Variant, s As String Set MyRng = mydata.Range("C6:C" & mydata.Cells(mydata.Rows.Count, "C").End(xlUp).Row) Set Sh = New Collection With Application .ScreenUpdating = False .DisplayAlerts = False End With For Each WS In Sheets If WS.Name <> mydata.Name Then WS.Delete Next On Error Resume Next For Each cell In MyRng.Cells Sh.Add cell.Value, CStr(cell.Value) Next cell On Error GoTo 0 For Each wsDest In Sh s = wsDest Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsDest ActiveSheet.DisplayRightToLeft = True With mydata DerLig = .Cells(.Rows.Count, "C").End(xlUp).Row .Range("A5").AutoFilter field:=3, Criteria1:=wsDest Set RngCopy = .Range("A5:C" & DerLig) RngCopy.Copy Sheets(s).Range("A5") .Select .[A5].AutoFilter End With Next wsDest For Each wscopy In ThisWorkbook.Worksheets If wscopy.Name <> mydata.Name Then For i = 1 To 3 wscopy.Cells.EntireRow.AutoFit wscopy.Columns(i).ColumnWidth = mydata.Columns(i).ColumnWidth wscopy.Rows("5:5").RowHeight = mydata.Rows("5:5").RowHeight wscopy.Columns("B:B").ColumnWidth = 70 wscopy.Activate With ActiveWindow .SplitRow = 5 .SplitColumn = 0 .FreezePanes = True End With Next End If Next wscopy mydata.Activate With Application .ScreenUpdating = True .DisplayAlerts = True End With End Sub اسلاميات 2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته الاكواد ربما لملف آخر وانت تحاول ضبطها على ملفك ربما يمكننا مساعدتك عند الإجابة على الإستفسارات التالية: بالنسبة للترحيل الملف عليه ارتباط من ملف آخر لبيانات آمين المستودع والمستلم ورئيس القسم. يمكنك تحديد عناوين الخلايا لحين كتابة الكود ثم وضع المعادلات الخاصة بك . B32 D32 G32............ ....... إضافة انك لابد أن توضح هل يتم تكرار نفس البيانات على طول الفاتورة او نسخها في اول صف فقط وكذلك التاريخ هل عمود التسلسل في شيت تقرير الصرف يتم نسخه من الفاتورة أم إضافة تسلسل جديد بالنسبة للاستعلام ماهو شرط البحث هل رقم الصنف مثلا......

يتم دالك بسبب نسخ قيمة Textbox مكان المعادلة هناك 2 حلول اما استبدال الكود بكود يتوافق مع شكل وتصميم الملف او تعديله بالطريقة التالية وهي الاستغناء عن وضع المعادلة يدويا وتعويضها بواسطة الاكواد على النحو التالي Private Sub CommandButton3_Click() Dim DerLig As Long, X As Long Dim WSData As Worksheet: Set WSData = ActiveSheet DerLig = WSData.Range("C" & WSData.Rows.Count).End(xlUp).row Application.ScreenUpdating = False If Me.TextBox1.Value = Empty Then: Exit Sub X = Application.Match(Val(TextBox1.Value), WSData.Columns("C"), 0) If Not IsError(X) Then For i = 2 To 18 WSData.Cells(X, i + 2).Value = Controls("TextBox" & i).Value WSData.Cells(X, i + 2).Value = WSData.Cells(X, i + 2).Value Next i End If For r = 1 To 18 Me("Textbox" & r) = "" Next r WSData.Range("C10").Value = 1 WSData.Range("C10:C" & DerLig).DataSeries , xlDataSeriesLinear ' وضع المعادلة WSData.Range("P10:P" & DerLig).Formula = "=IF(N10="""","""",""(""& O10&"" / ""&N10&"")"")" With WSData.Range("P10:P" & DerLig) .Value = .Value End With End Sub مني 4.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي حاولت تنفيدها بطريقة اخرى لتكون النتائج ادق وعدم تسبب المعادلات بثقل للملف زيادة على غياب تطابق عناوين الاعمدة على الجداول ودالك بتحويل المعادلات الى اكواد ووضع لكل يوم كود معين يتم تنفيده بشرط قيمة الخلية S3 ملاحظة 1) لقد قمت بحدف المغادلة الخاصة بجلب اسم اليوم من التاريخ في الخلية S3 ووضعت قائمة منسدلة تتضمن الايام من الاحد الى الخميس عند اختيارك اليوم المناسب يتم جلب بياناته تلقائيا 2) تم الاستغناء على معادلة الترقيم التلقائي للبيانات في عمود A واستبدالها بالاكواد 3) يتم تنفيد الكود المناسب عند التغيير في عمود الاسماء تلقائيا الكود الخاص بيوم الاحد للتوضيح Sub Sunday() Dim F1$, F2$, F3$, F4$, F5$, F6$, F7$, F8$, A$, B$, J% Dim MyRng As Range, MyDst As Range, Title As Range, R As Range, D As Range Dim MyDest As Worksheet: Set MyDest = Feuil1 Dim MyData As Worksheet: Set MyData = Feuil2 A = MyDest.Name B = MyData.Name Set C = MyData.Range("$D$4:$M$24") Set D = MyDest.Range("A22:A31") Set Title = MyDest.Range("B22:B31") Set MyRng = MyDest.Range("F22:U31") Application.ScreenUpdating = False MyDest.Unprotect "0000" D.ClearContents With MyDest F1 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",2,0),"""")" F2 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",4,0),"""")" F3 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",5,0),"""")" F4 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",6,0),"""")" F5 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",7,0),"""")" F6 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",8,0),"""")" F7 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",9,0),"""")" F8 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",10,0),"""")" [F22] = F1: [H22] = F2: [J22] = F3: [L22] = F4: [N22] = F5: [P22] = F6: [R22] = F7: [T22] = F8 .Range("F22:U22").AutoFill Destination:=.Range("F22:U31"), Type:=xlFillDefault MyRng.Value = MyRng.Value For Each R In Title If R.Value <> Empty Then J = J + 1 R.Offset(0, -1).Value = Format(J, "0") End If Next MyRng.Replace 0, "", xlWhole End With MyDest.Protect "0000" End Sub الكود الخاص بتنفيد الكود المناسب عند التغيير في خلية اليوم Sub Results() Select Case Range("S3") Case "الأحد": Sunday Case "الاثنين": Monday Case "الثلاثاء": Tuesday Case "الأربعاء": Wednesday Case "الخميس": Thursday End Select End Sub مع وضع الكود التالي في Worksheet.Change الورقة 1 Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("B22:B31")) Is Nothing Then Application.EnableEvents = False Call Results Application.EnableEvents = True Exit Sub End If If Not Intersect(Target, Range("S3")) Is Nothing Then Application.EnableEvents = False Call Results Application.EnableEvents = True End If On Error GoTo 0 End Sub التقرير اليومي مبرمج 2023.xlsm

لكن أخي الملف غير مطابق للصورة المرفقة اين مكان وجود الجدول الذي يتضمن أسماء الأيام