بحث وترحيل بالتنسيق

[marwa41]

عند وجود مكان استخدام جديد يبحث فى الاوراق وعدم وجدها يتم الانشاء بنفس الطريقة وايضا المترحيل على الشيتات1.xlsmخازن وايضا الصنف 

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

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

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

Sub CrNewSheets()
Dim dic As Object, arr As Variant, Itm
Dim i As Long, ws As Worksheet
Set ws = Sheets("مخازن رقم 1")
Set dic = CreateObject("scripting.dictionary")
arr = ws.Range("J2:J" & ws.Range("J" & Rows.Count).End(3).Row).Value
For i = 1 To UBound(arr)
dic(arr(i, 1) & "") = ""
Next
On Error Resume Next
ws.Range("A1:K1").Copy
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
Sheets(Itm).Range("A1").PasteSpecial xlPasteAll
End If
End If
Next
Application.CutCopyMode = False
End Sub

 

[marwa41]

شكرا لك اخى 

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

فى كلا من مكان الاستخدام والصنف والمخزن

[marwa41]

ترحيل على الشيتات1.xlsm

حل على هذا المثال

ترحيل على الشيتات1.xlsmترحيل على الشيتات1.xlsm

[عبدالفتاح في بي اكسيل]

اعتقد  ان هذا  الماكرو يفي  بمتطلباتك 

اكتبي  رقم  العمود   الذي  تريدينه   ان  يقوم  بترحيل  بياناته

Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer

Application.ScreenUpdating = False
vcol = Application.InputBox(Prompt:=" اي العمود  الذي  تريد فرزه", title:="فلترة عمود", Default:="3", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
'Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub

 

تم تعديل نوفمبر 25, 2021 بواسطه عبدالفتاح في بي اكسيل

[marwa41]

شكرا لك على الاهتمام لكن 

اريد عدد 3 اعمدة للترحيل وليس عمود واحد هما (f  - j -k)

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

[marwa41]

بصراحة كود ممتاز جدا  بارك اله فيك