ميلان قام بنشر فبراير 25, 2021 مشاركة قام بنشر فبراير 25, 2021 السلام عليكم اصدقائي لدي كود قام بكتابته استاذنا الكبير سليم حاصيبا واعمل عليه وهو ممتاز الية الكود ترحيل البيانات من شيت لاخر وعند الضغط على زر طباعة يتغير لون صف العامود الذي اخترته الى لون ازرق كاشف والذي اصبح غير واضح لاني البس نظارات اريد تغيير اللون الى اصفر اساسي وشكرا للجميع الاخوة في هذا المنتدى الرائع الكود كالتالي في الشيت الاول والثاني : Option Explicit Dim S As Worksheet Dim T As Worksheet Dim last As Long, Ro% Dim s_rg As Range Dim i%, K%, My_ro1%, My_ro2%, My_ro% Dim M As Byte, n As Byte, xx As Byte '++++++++++++++++++++++++++++++++ Sub Fatura() Application.ScreenUpdating = False Set S = Sheets("Source") Set T = Sheets("Target") xx = 1 last = S.Cells(Rows.Count, 1).End(3).Row If Val(T.Range("J1")) <= 0 Then i = 1 Else i = Int(Abs(T.Range("J1"))) End If T.Range("J1") = i T.Range("Rg_ALL").ClearContents For K = i + 3 To i + 10 If K > last Then Exit For Select Case xx Mod 8 Case 1: M = 2: n = 2 Case 2: M = 2: n = 5 Case 3: M = 11: n = 2 Case 4: M = 11: n = 5 Case 5: M = 20: n = 2 Case 6: M = 20: n = 5 Case 7: M = 29: n = 2 Case 0: M = 29: n = 5 End Select S.Cells(K, 1).Resize(, 7).Copy T.Cells(M, n).PasteSpecial _ 12, Transpose:=True xx = xx + 1 Next Application.CutCopyMode = False Print_Area T.Cells(2, 1).Select Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++ Sub Print_Area() Set T = Sheets("Target") Ro = T.Cells(Rows.Count, 1).End(3).Row For i = 2 To Ro - 6 Step 9 If T.Cells(i, 2) <> "" Then My_ro1 = i + 6 End If Next For i = 2 To Ro - 6 Step 9 If T.Cells(i, 5) <> "" Then My_ro2 = i + 6 End If Next My_ro = Application.Max(My_ro1, My_ro2) T.PageSetup.PrintArea = T.Range("A1:E" & My_ro).Address End Sub الشبيت الثاني Option Explicit Dim S As Worksheet Dim B As Worksheet Dim last%, i% Dim dic As Object Dim Mon_array Dim Itm Dim Nb% '++++++++++++++++++++++++++++++++ Sub Fatura_One() Set S = Sheets("Source") Set B = Sheets("By_one") Set dic = CreateObject("Scripting.Dictionary") last = S.Cells(Rows.Count, 1).End(3).Row S.Range("A4").Resize(last, 9).Interior.ColorIndex = xlNone For i = 4 To last If Not IsEmpty(S.Cells(i, 2)) Then S.Cells(i, 1).Resize(, 9).Interior.ColorIndex = 35 Mon_array = Application.Transpose _ (S.Cells(i, 1).Resize(, 9)) Mon_array = Join(Application.Transpose(Mon_array), "*") dic(dic.Count) = Mon_array End If Next If dic.Count Then For Each Itm In dic.Items() B.Range("E6").Resize(9) = _ Application.Transpose(Split(Itm, "*")) '========================== B.PrintPreview '======================== Next End If Set dic = Nothing End Sub '+++++++++++++++++++ Sub New_Month() Set S = Sheets("Source") last = S.Cells(Rows.Count, 1).End(3).Row S.Range("A4:I" & last).Interior.ColorIndex = xlNone S.Range("K4:K" & last) = vbNullString End Sub الشيت الاساسي جزاكم الله كل خير والملف في الاسفل OTOKAR 21.2.2021.xlsm رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر فبراير 25, 2021 أفضل إجابة مشاركة قام بنشر فبراير 25, 2021 في هذا السطر من الكود استبدل الرقم 35 الى الرقم 6 S.Cells(i, 1).Resize(, 9).Interior.ColorIndex = 35 1 رابط هذا التعليق شارك More sharing options...
ميلان قام بنشر فبراير 25, 2021 الكاتب مشاركة قام بنشر فبراير 25, 2021 استاذنا الكريم شكرا لمرورك الجميل واود ان اكرر شكري بأن الكود أعمل عليه وهوممتاز ولا يوجد اي خلل شكرا لك من القلب رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان