ترحيل حسب النوع للصفحة الخاصة به

[ابو منذر عبد الله]

هذا الملف لاحد الاخوة هنا و قمت بالتغيير عليه

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

و شكرا

Nour_Vise_versa (3).xlsm

[ابراهيم الحداد]

السلام عليكم ورحمة الله

استخدم هذا الكود

Sub Transf()
Dim ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Tmp As Variant
Dim LR As Long, LS As Long, i As Long, j As Long, p As Long
Set Sh = Sheets("BASS")
LR = Sh.Range("B" & Rows.Count).End(3).Row
Arr = Sh.Range("A5:E" & LR).Value
ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For Each ws In Worksheets
LS = ws.Range("B" & Rows.Count).End(3).Row
For i = 1 To UBound(Arr, 1)
If Arr(i, 5) = ws.Name Then
p = p + 1
For j = 1 To 5
Tmp(p, j) = Arr(i, j)
Next
End If
Next
If p > 0 Then ws.Range("A" & LS).Resize(p, UBound(Tmp, 2)).Value = Tmp
p = 0

Next ws


End Sub

 

[marwa41]

زود حضرتك على الكود تكون عملك بسم الله مشاء الله 

تنسيق الصفحة التى يرحل عليها البيانات 

على اساس يدور على الصفحة 

لو موجودة يرحل عليها اى يكمل البيانات على البيانات السابقة 

لو مش موجودة يعمل صفحة بنفس الاسم ويرحل عليها البيانات 

 

[ابراهيم الحداد]

السلام عليكم ورحمة الله

الكود التالى يقوم بانشاء ورقة جديدة فى خالة عم وجودها

Sub CrNewSheets()
Dim dic As Object, Tmp As Variant, Itm
Dim i As Long, Bok As Worksheet
Set Bok = Sheets("BASS")
Set dic = CreateObject("scripting.dictionary")
Tmp = Bok.Range("E5:E" & Bok.Range("C" & Rows.Count).End(3).Row).Value
For i = 1 To UBound(Tmp)
dic(Tmp(i, 1) & "") = ""
Next
On Error Resume Next
For Each Itm In dic.keys
If Len(Trim(Itm)) > 0 Then
If Len(Worksheets(Itm).Name) = 0 Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = Itm
End If
End If
Next
End Sub

 

ضعى هذه العبارة فى اول سطر فى الكود المدرج بمشاركتى الاولى

Call CrNewSheets

و الزر يخصص للكود الاول فقط

 

 

[ابو منذر عبد الله]

مشكور يا اخي و لو امكن ينقل صفحة tout  حسب نوعها و قيمتها حسب التاريخ المحدد لها يعني يكون تنسيق الصفحات مثل bass 

و شكرا لك