تحويل الصف الى عمود عن طريق vba

[ابو هاله النبلسي]

السلام عليكم 

في هذا الشيت يوجد صف يبدي من استقطاع (4) 10 مليون العمارة 9  ويوجد عمود فيه اسماء الموظفن 26 موظف عن النقر على الصف استقطاع (4) 10 مليون العمارة 9  او باقي الصفوف احتاج وفق ماكرو يتم انشاء صفحة جديدة تنقل معاها كل الموضفين الذين لديهم بيانات في استقطاع (4) 10 مليون العمارة 9  ويتم ترحيلهم الى صفحة جديده هايبرلنك وشكر لكم 

شيت.rar

[سليم حاصبيا]

كان من الواجب عليك حفظ الملكية الفكرية التي هي من اساسيات هذا المنتدى و اعلان اسم  من وضع لك الكود في الملف 

ربما كان الحل في الشيت Repport من هذا الملف

 

Saerch_by_column.xlsm

[ابو هاله النبلسي]

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

استاذي بعد اطلاعي على الملف ياريت لو يتم اضافة زر شبيه  ADD HYE يتم من خلاله انشاء صفحة باي صف يتم النقر عليه مع قائمة اسماء الموضفين على يمين الشيت مثل المرفق ادناه SSSSSSSSSSSSS.xlsx

SSSSSSSSSSSSS.xlsx

[سليم حاصبيا]

يا اخي عندك 67 عامود وبالتالي 67 صفحة زيادة اضافة الى صفحة لكل عميل مما يزيد عدد الصفحات كثيراً (100 صفحة تقريباً) و يثقل البرنامج  ويسبب ببطئه

 

[ابو هاله النبلسي]

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

[سليم حاصبيا]

حيث ان الداتا عندك لا تشكل جدولاً للاكسل (هناك خلايا مدمجة ويجب ان يكون بجانب الجدول عامود فارغ وفوقه صف فارغ)

تم ادراج صف فارغ (رقم 7) وعامود فارغ B ليفصل الجدول عن بقية الخلايا )

تم انشاء ملف جديد بما تريد

(للانتقال الى اي ورقة فقط اضغط  DoubleClick على اسمها من الورقة  Salim )

 

الكود

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim My_name$
On Error Resume Next
If Not Intersect(Target, Range("d8:Pb8")) Is Nothing _
And Target.Count = 1 Then
 My_name = Left(Target, 30)
 Sheets(My_name & "").Select
 End If
End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++++++++
Option Explicit

Sub Create_Sheet()
 Dim Tg As Worksheet
 Dim i%, My_name$
 Dim RGA As Range, Var_Rg As Range
 Set RGA = Salim.Range("C8").CurrentRegion.Columns(1)
 If Salim.AutoFilterMode Then
   Salim.Range("c8").CurrentRegion.AutoFilter
 End If
 Application.DisplayAlerts = False
 
  For Each Tg In Sheets
  If Tg.Name <> "Salim" Then Tg.Delete
    Next Tg
  Application.DisplayAlerts = True
 For i = 4 To 7 'تستطيع ان تغير الرقم 7 الى اي رقم اقل من 72 (عدد الأعمدة+4) 
 Set Var_Rg = Salim.Cells(8, i).CurrentRegion.Columns(i - 2)
 
  Var_Rg.AutoFilter 1, Criteria1:="<>"
  If Len(Salim.Cells(8, i)) > 30 Then
    My_name = Left(Salim.Cells(8, i), 30)
  Else
    My_name = Salim.Cells(8, i)
  End If

  Sheets.Add(after:=Sheets(Sheets.Count)).Name = My_name
  With ActiveSheet
       RGA.SpecialCells(12).Copy .Range("B2")
       Var_Rg.SpecialCells(12).Copy .Range("C2")
      .Range("B:C").Columns.AutoFit
      .Hyperlinks.Add Anchor:=.Range("E2"), Address:="", SubAddress:= _
       "Salim!A9", TextToDisplay:="Goto SALIM"
  End With

   Salim.Range("C8").CurrentRegion.AutoFilter
   
   '============================
  Next
  Salim.Select
End Sub

الملف مرفق

 

 

My_filter.xlsm

[ابو هاله النبلسي]

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

الشيت.xlsx

[سليم حاصبيا]

تم التعديل كما تريد

Option Explicit

Sub Create_Sheet_WITH_HYPER()
      Rem =======>> CREATED BY SALIM HASBAYA ON 20/3/2020
 Dim Tg As Worksheet
 Dim i%, My_name$
 Dim RGA As Range, Var_Rg As Range
 Dim Final_Rg As Range, Ro%
 Application.ScreenUpdating = False
 Set RGA = Salim.Range("C8").CurrentRegion.Columns(1)
 If Salim.AutoFilterMode Then
   Salim.Range("c8").CurrentRegion.AutoFilter
 End If
 Application.DisplayAlerts = False
 
  For Each Tg In Sheets
  If Tg.Name <> "Salim" Then Tg.Delete
    Next Tg
  Application.DisplayAlerts = True
 For i = 4 To 6 'تستطيع ان تغير الرقم 7 الى اي رقم اقل من 72 (عدد الأعمدة+4)
 Set Var_Rg = Salim.Cells(8, i).CurrentRegion.Columns(i - 2)
 
  Var_Rg.AutoFilter 1, Criteria1:="<>"
  If Len(Salim.Cells(8, i)) > 30 Then
    My_name = Left(Salim.Cells(8, i), 30)
  Else
    My_name = Salim.Cells(8, i)
  End If

  Sheets.Add(after:=Sheets(Sheets.Count)).Name = My_name
  With ActiveSheet
       RGA.SpecialCells(12).Copy .Range("B2")
       Var_Rg.SpecialCells(12).Copy .Range("C2")
      .Range("B:C").Columns.AutoFit
      .Hyperlinks.Add Anchor:=.Range("E2"), Address:="", SubAddress:= _
       "Salim!A9", TextToDisplay:="Goto SALIM"
  End With
   Set Final_Rg = ActiveSheet.Range("B2").CurrentRegion
   Ro = Final_Rg.Rows.Count
    If Ro > 1 Then

   With ActiveSheet
    .Range("A2") = "N#"
     .Range("A" & Ro + 2).Offset(, 1) = "Sum"
     .Range("A3").Resize(Ro - 1) = Evaluate("Row(1:" & Ro & ")")
     .Range("A" & Ro + 2).Offset(, 2).Formula = "=SUM(C3:C" & Ro + 1 & ")"
     .Range("A" & Ro + 2).Offset(, 2).Value = _
        .Range("A" & Ro + 2).Offset(, 2).Value
     .Range("B2:b3").Copy
     .Range("A2").Resize(Ro).PasteSpecial Paste:=xlPasteFormats
     .Range("A" & Ro + 2).Resize(, 3).PasteSpecial Paste:=xlPasteFormats
     
   End With
   Application.CutCopyMode = False
    End If
   Salim.Range("C8").CurrentRegion.AutoFilter
   
   '============================
  Next
  Salim.Select
   Application.ScreenUpdating = True
End Sub

الملف مرفق من جديد

My_NEW_filter.xlsm

[سليم حاصبيا]

وتحيا مصر ام الدنيا 

مع تأييدي المطلق لهذه الكلمة    أقول أنا لبناني "تحيا الثورة" وربنا يحفظ بلد الأرز الخالد و كلّنا للوطن

[ابو هاله النبلسي]

ربنا يوفقك ويخليك كلنا اخوة ان شاء الله ويحفظكم