فتح شيتات على حسب الاسم

[محمد عبد الناصر]

عايز كود يقوم بفتح شيت لكل اسم موجود في العمود 
B

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

طالما تريد الإجابة عن طلبك بالأكواد .. فكان عليك لزاماً رفع الملف بإمتداد الماكرو XLSM

hg.xlsm

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

 قم بتسمية الشيت الاول باسم  Salim

ثم نفذ هذا الماكرو

Option Explicit
'+++++++++++++++++++++++++++++++++++++++++

Sub ADD_SH_with_HyperLink()
'code to add Sheets One Time WITH HYPERLINKS
'Crated By Salim Hasbaya On 1/10/2020
  Dim Rg As Range
  Dim sh As Worksheet
  Dim LB%, i%, x%, t%
  Dim ws As Worksheet

Set sh = Sheets("Salim")

Application.ScreenUpdating = False
Application.DisplayAlerts = False
    For Each ws In Sheets
        If ws.Name <> "Salim" Then
          ws.Delete
        End If
    Next
 Application.DisplayAlerts = True
LB = sh.Cells(Rows.Count, 2).End(3).Row

 For x = 2 To LB
    If sh.Range("b" & x) <> "" Then
      t = sh.Range("b" & x).MergeArea.Rows.Count
        If Not Application.Evaluate("ISREF('" & sh.Range("b" & x) & "'!A1)") Then
       Sheets.Add after:=Sheets(Sheets.Count)
    With ActiveSheet
            .Name = sh.Range("b" & x)
             sh.Range("a1:d1").Copy
              .Range("A1").PasteSpecial (xlPasteAll)
              .Range("C:C").Delete
              .Range("A2") = sh.Range("A" & x)
              .Range("B2") = sh.Range("B" & x)
              .Range("C2") = sh.Range("D" & x)
            .Hyperlinks.Add Anchor:=.Range("F1"), _
             Address:="", SubAddress:= _
             "Salim!A1", TextToDisplay:="Goto SALIM"
          
          With .Range("a1").CurrentRegion
            .ColumnWidth = 19
            .Borders.LineStyle = 1
            .Font.Bold = True
            .Font.Size = 16
            .Rows(2).InsertIndent 1
            .Cells(2, 1).Select
          End With

         With .Range("F1")
              With .Font
                .Bold = True: .Size = 20
                .ColorIndex = vbBlack
                .Italic = True
              End With
          .Interior.ColorIndex = 6
          .Borders.LineStyle = 1
          .Columns.AutoFit
        End With
  End With
        End If        'sh,exist
   End If             '.value<>""
   x = x + t - 1

Next x
   sh.Select
   Application.ScreenUpdating = True

End Sub

'++++++++++++++++++++++++++++++++++++++++++++++++++

الملف مرفق

ABd_Naser_Sheet.xlsm

[محمد عبد الناصر]

ماشاء الله استاذ سليم تاربك الله فيك وفي مجهوداتك 
هو 80% من المطلوب 

اريد ان لا تجمع لاني اريد رقم البند 

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

اريد ان ينقل الملفات كما هو في الملف الاصلي هذا الملف الاصلي

hg.xlsm

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

كان من المفروض ان تقول هذا الشيء من البداية بدون اضاعة الوقت لانشاء الكود

أعتذر عن المتابعة (لا وقت لذلك) 

[محمد عبد الناصر]

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

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

تم مغالجة الأمر و زيادة حبتين بجيث يمكنك الاتنقال الى اي شيت من خلال الضغط عل اسمها من الخلايا الصفراء صغحة (Salim)

والعودة من اي شيت الى الرئيسية من حلال الضغط على الخلية Go to Salim

 ( لكن في المرة القادمة عليك بتوضيح كل شيء لعدم اهدار الوقت)

Option Explicit
'+++++++++++++++++++++++++++++++++++++++++

Sub ADD_SH_with_HyperLink()
'code to add Sheets One Time WITH HYPERLINKS
'Crated By Salim Hasbaya On 1/10/2020
'  Dim Rg As Range
  Dim sh As Worksheet
  Dim LB%, i%, x%, t%
  Dim Ws As Worksheet

Set sh = Sheets("Salim")

Application.ScreenUpdating = False
Application.DisplayAlerts = False
    For Each Ws In Sheets
        If Ws.Name <> "Salim" Then
          Ws.Delete
        End If
    Next
 Application.DisplayAlerts = True
LB = sh.Cells(Rows.Count, 2).End(3).Row

 For x = 2 To LB
    If sh.Range("b" & x) <> "" Then
      t = sh.Range("b" & x).MergeArea.Rows.Count
        If Not Application.Evaluate("ISREF('" & sh.Range("b" & x) & "'!A1)") Then
       Sheets.Add after:=Sheets(Sheets.Count)
    With ActiveSheet
            .Name = sh.Range("B" & x)
             sh.Range("A1:D1").Copy
              .Range("A1").PasteSpecial (11)
              .Range("A1").PasteSpecial (8)
            .Hyperlinks.Add Anchor:=.Range("F1"), _
             Address:="", SubAddress:= _
             "Salim!A1", TextToDisplay:="Goto SALIM"
          
          With .Range("A1").CurrentRegion
            .ColumnWidth = 19
            .Borders.LineStyle = 1
            .Font.Bold = True
            .Font.Size = 16
            .Rows(2).InsertIndent 1
            .Cells(2, 1).Select
          End With

         With .Range("F1")
              With .Font
                .Bold = True: .Size = 20
                .ColorIndex = vbBlack
                .Italic = True
              End With
          .Interior.ColorIndex = 6
          .Borders.LineStyle = 1
          .Columns.AutoFit
        End With
  End With
        End If        'sh,exist
   End If             '.value<>""
   x = x + t - 1

Next x
   sh.Select
   add_data
   add_Hyper
   Application.CutCopyMode = False
   Application.ScreenUpdating = True

End Sub
'++++++++++++++++++++++++++++++++++
Sub add_data()
  Dim sh As Worksheet
  Dim LB%, i%, x%, t%
  Dim Ws As Worksheet
  Dim spec_sh As Worksheet
  Dim LS%, Ro%
Set sh = Sheets("Salim")
LS = sh.Cells(Rows.Count, 1).End(3).Row

  For i = 2 To LS
    t = sh.Cells(i, 2).MergeArea.Rows.Count
       Set spec_sh = Sheets(sh.Cells(i, 2) & "")
        Ro = spec_sh.Cells(Rows.Count, 1).End(3).Row + 1
        sh.Cells(i, 1).Resize(t, 4).Copy _
     spec_sh.Range("A" & Ro)
    i = i + t - 1
  Next i
   

End Sub
'+++++++++++++++++++++++
Sub add_Hyper()
 Dim Ws As Worksheet
 Dim K%
 Set Ws = Sheets("Salim")
 Ws.Range("F2:F" & Sheets.Count).Clear
 For K = 2 To Sheets.Count
  Ws.Range("F" & K) = Sheets(K).Name
  
  Ws.Range("F" & K).Hyperlinks.Add _
  Anchor:=Ws.Range("F" & K), _
  Address:="", _
  SubAddress:="'" & Sheets(K).Name & "'!A1", _
  TextToDisplay:="Go TO " & Sheets(K).Name
 Next
 With Ws.Range("F2").Resize(K - 2)
 .Interior.ColorIndex = 6
 .Borders.LineStyle = 1
 .InsertIndent 1
 .Font.Size = 14: .Font.Bold = True
 End With
End Sub

الملف مرفق

 

Adb_Explicit.xlsm

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

اذا كان هذا المطلوب اضغط على افضل اجابة لاغلاق الموضوع

[محمد عبد الناصر]

تم

افضل اجابة

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