marwa41 قام بنشر نوفمبر 23, 2021 مشاركة قام بنشر نوفمبر 23, 2021 عند وجود مكان استخدام جديد يبحث فى الاوراق وعدم وجدها يتم الانشاء بنفس الطريقة وايضا المترحيل على الشيتات1.xlsmخازن وايضا الصنف رابط هذا التعليق شارك More sharing options...
ابراهيم الحداد قام بنشر نوفمبر 24, 2021 مشاركة قام بنشر نوفمبر 24, 2021 السلام عليكم ورحمة الله استخدمى هذا الكود 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 2 رابط هذا التعليق شارك More sharing options...
marwa41 قام بنشر نوفمبر 24, 2021 الكاتب مشاركة قام بنشر نوفمبر 24, 2021 شكرا لك اخى لكن طلبى متعدد عندما يوجد مكان مستخدم جديد يبحث فى الورقة المستخدم وعدم وجوده ينشاء ورقة جديدة يقوم بترحيل العمل بالتنسيق فى كلا من مكان الاستخدام والصنف والمخزن رابط هذا التعليق شارك More sharing options...
marwa41 قام بنشر نوفمبر 24, 2021 الكاتب مشاركة قام بنشر نوفمبر 24, 2021 ترحيل على الشيتات1.xlsm حل على هذا المثال ترحيل على الشيتات1.xlsmترحيل على الشيتات1.xlsm رابط هذا التعليق شارك More sharing options...
أفضل إجابة عبدالفتاح في بي اكسيل قام بنشر نوفمبر 25, 2021 أفضل إجابة مشاركة قام بنشر نوفمبر 25, 2021 (معدل) اعتقد ان هذا الماكرو يفي بمتطلباتك اكتبي رقم العمود الذي تريدينه ان يقوم بترحيل بياناته 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 بواسطه عبدالفتاح في بي اكسيل 2 رابط هذا التعليق شارك More sharing options...
marwa41 قام بنشر نوفمبر 25, 2021 الكاتب مشاركة قام بنشر نوفمبر 25, 2021 شكرا لك على الاهتمام لكن اريد عدد 3 اعمدة للترحيل وليس عمود واحد هما (f - j -k) ممكن ايضا تضبيق على ورقة العمل بدون ازعاج لجهلى بالاكواد رابط هذا التعليق شارك More sharing options...
marwa41 قام بنشر نوفمبر 25, 2021 الكاتب مشاركة قام بنشر نوفمبر 25, 2021 بصراحة كود ممتاز جدا بارك اله فيك 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان