اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


marwa41
إذهب إلى أفضل إجابة Solved by عبدالفتاح في بي اكسيل,

الردود الموصى بها

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

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

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

 

  • Thanks 2
رابط هذا التعليق
شارك

شكرا لك اخى 

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

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

رابط هذا التعليق
شارك

  • أفضل إجابة

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

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

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

 

تم تعديل بواسطه عبدالفتاح في بي اكسيل
  • Thanks 2
رابط هذا التعليق
شارك

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

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

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

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information