دالة النسخ

[وادي سلي]

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

المشاريع.xlsx

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

جرب هذا الملف

الكود

Option Explicit

Sub transfer_data()
Dim S1 As Worksheet, S2 As Worksheet
Dim Rg1 As Range
Set S1 = Sheets("ورقة1"): Set S2 = Sheets("ورقة2")
If S2.Range("A1").CurrentRegion.Rows.Count > 1 Then _
   S2.Range("A1").CurrentRegion.Offset(1) _
   .Resize(S2.Range("A1").CurrentRegion.Rows.Count - 1).Clear
   

Set Rg1 = S1.Range("A1").CurrentRegion
If Rg1.Rows.Count = 1 Then Exit Sub
Set Rg1 = Rg1.Offset(1).Resize(Rg1.Rows.Count - 1)
Rg1.Columns(2).Copy
S2.Range("A2").PasteSpecial Paste:=xlPasteValues, Transpose:=True

Application.CutCopyMode = False

With S2.Range("A1").CurrentRegion.Rows(2)
.InsertIndent 1: .Borders.LineStyle = 1
.Font.Size = 14: .Font.Bold = True
.Interior.ColorIndex = 19: .Cells(1, 1).Select

End With

End Sub

الملف مرفق

Mashri3.xlsm

[Ali Mohamed Ali]

بعد اذن استاذنا سليم ولإثراء الموضوع ,,فهذا حل ايضا بمعادلة المصفوفة

=IFERROR(INDEX(ورقة1!$C:$C,SMALL(IF(ورقة1!$B:$B=A$2,ROW(A$2:A$5000)-ROW(A$2)+1),ROWS($A$5:A5))),"")

 

المشاريع1.xlsx

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

ربما ينال الاعجاب هذا الملف

1-لا يتم تكرار الأسماء

2-تحديد المجموع لكل اسم

الكود

Sub transfer_data_with_sum()
Dim S1 As Worksheet, S2 As Worksheet
Dim Rg1 As Range, x As Range
Dim Dic As Object

Set S1 = Sheets("ورقة1"): Set S2 = Sheets("ورقة2")
If S2.Range("A1").CurrentRegion.Rows.Count > 1 Then _
   S2.Range("A1").CurrentRegion.Offset(1) _
   .Resize(S2.Range("A1").CurrentRegion.Rows.Count - 1) _
   .Clear
Set Dic = CreateObject("Scripting.Dictionary")
Set Rg1 = S1.Range("A1").CurrentRegion
If Rg1.Rows.Count = 1 Then Exit Sub
Set Rg1 = Rg1.Offset(1).Resize(Rg1.Rows.Count - 1)
 For Each x In Rg1.Columns(2).Cells
  Dic(x.Value) = Val(Dic(x.Value)) + Val(x.Offset(, 1))
 Next x
 If Dic.Count = 0 Then Exit Sub
  With S2.Range("B2").Resize(, Dic.Count)
  .Value = Dic.keys
  .Offset(1) = Dic.Items
  End With
  
  S2.Range("A2") = "الإسم": S2.Range("A3") = "المجموع"
 
 With S2.Range("a2").Resize(2, S2.Range("A1").CurrentRegion.Columns.Count)
    .InsertIndent 1: .Borders.LineStyle = 1
    .Font.Size = 14: .Font.Bold = True
    .Rows(1).Interior.ColorIndex = 19
    .Rows(2).Interior.ColorIndex = 28
        
 End With
End Sub

 الملف مرفق

 

 

Mashri3 _with_Sum.xlsm