ترحيل الاسماء حسب الحروف الى شيتات

[kkfhvvv]

السلام عليكم

عندي مجموعة من الاسماء 

اريد ترحيلها الى شيتات حسب الاحرف

والاسماء في ازدياد 

جزيتم خيرا

ترحيل الاسماء حسب الاحرف الى شيتات.xlsx

[lionheart]

Not so clear but try this code

Sub Test()
    Dim a, letters, i As Long, ii As Long, k As Long
    a = Sheet1.Range("C1").CurrentRegion.Value
    Rem letters = Split("ا,أ,إ,آ", ",")
    letters = Split("ب", ",")
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
    For i = 2 To UBound(a, 1)
        If IsNumeric(Application.Match(Left(a(i, 2), 1), letters, 0)) Then
            k = k + 1
            For ii = LBound(a, 2) To UBound(a, 2)
                b(k, ii) = a(i, ii)
            Next ii
        End If
    Next i
    If k > 0 Then
        With Sheet2
            .Columns("C:E").ClearContents
            .Range("C1").Resize(, 3).Value = Sheet1.Range("C1").Resize(, 3).Value
            .Range("C2").Resize(k, UBound(b, 2)).Value = b
        End With
    End If
End Sub

 

[kkfhvvv]

السلام عليكم

يظهر هذا الخطأ

[محمد هشام.]

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

 بعد معاينة الملف لاحظت انه هناك أسماء مختلفة تبدأ بحرف الألف

مثلا . إبراهيم ، أدهم ، آياد  ، أحمد  ....... احسان 

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

او تجاهل الأمر وإعادة تصحيح وتوحيد نوع الكتابة من طرفك 

[kkfhvvv]

السلام عليكم

كل اسم يبدأ بحرف أ  يتم دمجها في شيت واحد

وكذلك باقي الاسماء ، فمثلا حرف (ب) كل اسم يبدأ بحرف الباء يدمج في شيت واحد

تسلم

ممنون

تم تعديل مايو 8 بواسطه kkfhvvv

[محمد هشام.]

تفضل اخي الكود طويل نوعا ما لاكنه سريع  

Sub Create_Worksheets()
    Dim desWS As Worksheet, srcWS As Worksheet
    Dim rCrit As Range, rngFilter As Variant
    Dim Irow As Long, LastCol As Long
    Dim rgData As Range, destRng As Range
    Dim Dic As Object, dictKey As String, Cpt As Variant
    Dim Destination As Range, i As Long
    Set desWS = Worksheets("البيانات")
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        On Error Resume Next
        
    With desWS
        Irow = .Cells(Rows.Count, "D").End(xlUp).Row
        LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column + 2
        Set rCrit = .Range("C1:E" & Irow): rngFilter = rCrit.Columns(2)
        
        ' نطاق المعايير
        Set rgData = .Cells(1, LastCol): rgData.Value = .[D1]
        Set rgData = .Cells(1, LastCol).Resize(2)
    End With
       
    ' الحصول على مجموعة الحروف الفريدة - الحرف الأول من الاسم
    Set Dic = CreateObject("Scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    
    For i = 2 To UBound(rngFilter)
        dictKey = Left(rngFilter(i, 1), 1)
        If Not Dic.exists(dictKey) Then
            Dic(dictKey) = ""
        End If
    Next i
    
  ' رمز اظافي للتعامل مع حرف الالف
 '(ا,أ,إ,آ) & Unicode &  وتجميعه والذي يمكن أن يكون 4 أحرف  مختلفة
    
    Dim a As Variant, b As Boolean, Clé() As String, j As Long
    a = Array(1570, 1571, 1573, 1575)
    ReDim Clé(1 To UBound(a) + 1)
    For i = 0 To UBound(a)
        dictKey = ChrW(a(i))
        If Dic.exists(dictKey) Then
            b = True
            Dic.Remove dictKey
        End If
        j = j + 1
        Clé(j) = dictKey & "*"
    Next i
    If b Then
        dictKey = Replace(Join(Clé, ","), "*", "")
        Dic(dictKey) = ""
    End If
    
   '*مراجعة المعرفات مع إنشاء أو تحديث ورقة جديدة للمجموعة الحرفية ***
   For Each Cpt In Dic.keys
        ' ***التحقق من وجود ورقة العمل مسبقا***
       If Evaluate("ISREF('" & "حرف" & "-" & Cpt & "'!A1)") Then
            Set srcWS = Worksheets(Cpt)
            srcWS.UsedRange.Clear
        Else
            Set srcWS = Worksheets.Add(After:=Sheets(Sheets.Count))
            srcWS.Name = "حرف" & "-" & Cpt: Set Destination = srcWS.[A1]
        End If
        
       '** تصفية
        If Len(Cpt) > 1 Then
            rgData.Cells(2).Resize(UBound(Clé)) = Application.Transpose(Clé)
            Set rgData = rgData.CurrentRegion
        Else
            rgData.Offset(1).ClearContents
            rgData.Cells(2) = Cpt & "*"
            Set rgData = rgData.CurrentRegion
        End If
        rCrit.AdvancedFilter xlFilterCopy, rgData, Destination
     
     '***تنسيق عرض عمود المصدر***
        rCrit.EntireColumn.Copy
        srcWS.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
        [A1].Select: ActiveSheet.DisplayRightToLeft = True
    
    Dim nCount As Integer, shName As Range, lastrow As Long
    '***(ازالة التكرار في حالة وجوده (على الاوراق الجديدة ***

    lastrow = srcWS.Columns("A:C").Find(What:="*", SearchDirection:=xlPrevious, _
                                          SearchOrder:=xlByRows).Row
    'الاعمدة
     arr = [{1,2,3}]
     srcWS.Range(Cells(1, 1), srcWS.Cells(lastrow, 3)).RemoveDuplicates arr(1), Header:=xlNo
      Next Cpt
    
   'اظافة الارتباط التشعبي
    desWS.Columns("J:G").Clear: desWS.UsedRange.Hyperlinks.Delete
    
    j = 2
    For Each WS In ThisWorkbook.Worksheets
    If WS.Name Like "*ح*" Then
           nCount = nCount + 1
    ActiveWorkbook.Sheets("البيانات").Hyperlinks.Add _
    Anchor:=ActiveWorkbook.Sheets("البيانات").Cells(j, 10), Address:="", SubAddress:="'" & WS.Name & "'!A1", _
    TextToDisplay:=WS.Name
    Worksheets(WS.Name).Hyperlinks.Add Anchor:=Worksheets(WS.Name).[E2], Address:="", _
    SubAddress:="'" & desWS.Name & "'" & "!A1", TextToDisplay:="ورقةالبيانات"
           j = j + 1
        End If  
    Next WS
    ' استخراج اسماء  المجموعات الحرفية
     Set shName = desWS.Range("j2", desWS.Range("j" & desWS.Rows.Count).End(xlUp))
    For Each c In shName
        If WorksheetFunction.CountIf(shName, c) >= 1 Then If InStr(1, s, c) = 0 Then s = s & " ** " & c
    Next
         desWS.Activate
     .DisplayAlerts = True
   .ScreenUpdating = True
  End With
      resultat = IIf(s <> "", vbLf & Mid(s, 2), "")
   MsgBox resultat, vbInformation, "تم تحديث" & " : " & nCount & " " & "مجموعة بنجاح"
End Sub

 

ترحيل الاسماء حسب الاحرف الى شيتات V2.xlsm

تم تعديل مايو 8 بواسطه محمد هشام.

[kkfhvvv]

الله يرضى عليكم

تسلم

100 % - وفوق 100 %

ممكن عند الضغط على زر تحدث وتوزع الاحرف على الشيتات

أن

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

تسلم

 

[محمد هشام.]

ولك بالمثل اخي الكريم يسعدنا أننا استطعنا مساعدتك 

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

 

 

[kkfhvvv]

ممنون

جزاك الله عنا خيرا

[محمد هشام.]

اسف اخي على التاخير في الرد لاكنني عند الاشتغال على الملف ومراجعة الاكواد 

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

(رحم الله من عمل عملا فأتقنه)

  تفضل استبدل كود التوزيع بالكود التالي بعد تنقيحه بشكل افضل وادق

Sub Create_Worksheets()
              '09/05/2024     by:MOHAMEED HICHAM    www.officena.net     "منتدى الاكسيل" '
       '*********'Create Worksheets and Name Them With The First letters of The Name***********

    Dim WS As Worksheet, srcWS As Worksheet
    Dim rgData As Range, ColName As Variant
    Dim Lr As Long, lColumn As Long, Irow As Long
    Dim rCrit As Range, destRng As Range, tmp As Range
    Dim dicWS As Object, dictKey As String, Cpt As Variant
    Dim I As Long, x As Long, nCount As Integer, lastRow As Long

  With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
 ' نطاق المعايير
    Set WS = Worksheets("البيانات")
    With WS
       .Columns("J:G").Clear: .UsedRange.Hyperlinks.Delete
        Lr = .Cells(Rows.Count, "D").End(xlUp).Row
        lColumn = .Cells(1, Columns.Count).End(xlToLeft).Column + 2
        Set rgData = .Range("C1:E" & Lr)
        ColName = rgData.Columns(2)
        Set rCrit = .Cells(1, lColumn)
        rCrit.Value = .Range("D1")
        Set rCrit = .Cells(1, lColumn).Resize(2)
    End With
       
 ' الحصول على مجموعة الحروف الفريدة - الحرف الأول من الاسم
    Set dicWS = CreateObject("Scripting.dictionary")
    dicWS.comparemode = vbTextCompare
    For I = 2 To UBound(ColName)
    ' تجاهل الفراغات
    If ColName(I, 1) <> "" Then
        dictKey = Left(ColName(I, 1), 1)
        If Not dicWS.Exists(dictKey) Then
            dicWS(dictKey) = ""
        End If
        End If
    Next I
  ' رمز اظافي للتعامل مع حرف الالف
 '(ا,أ,إ,آ) & Unicode &  وتجميعه والذي يمكن أن يكون 4 أحرف  مختلفة
    Dim letters As Variant, réf As Boolean, arr() As String, j As Long
    letters = Array(1570, 1571, 1573, 1575)
    ReDim arr(1 To UBound(letters) + 1)
    For I = 0 To UBound(letters)
        dictKey = ChrW(letters(I))
        If dicWS.Exists(dictKey) Then
            réf = True
            dicWS.Remove dictKey
        End If
        j = j + 1
        arr(j) = dictKey & "*"
    Next I
    If réf Then
        dictKey = Replace(Join(arr, "-"), "*", "")
        dicWS(dictKey) = ""
    End If
  '*مراجعة المعرفات مع إنشاء أو تحديث ورقة جديدة للمجموعة الحرفية ***
    For Each Cpt In dicWS.Keys
      ' ***التحقق من وجود ورقة العمل مسبقا***
        If Evaluate("ISREF('" & Cpt & "'!A1)") Then
           'تحديث
            Set srcWS = Worksheets(Cpt)
            srcWS.UsedRange.Clear
        Else
          ' اظافة
            Set srcWS = Worksheets.Add(after:=Sheets(Sheets.Count))
            srcWS.Name = Cpt
        End If
        ' لصق البيانات
        Set tmp = srcWS.[A1]
        If Len(Cpt) > 1 Then
            rCrit.Cells(2).Resize(UBound(arr)) = Application.Transpose(arr)
            Set rCrit = rCrit.CurrentRegion
        Else
            rCrit.Offset(1).ClearContents
            rCrit.Cells(2) = Cpt & "*"
            Set rCrit = rCrit.CurrentRegion
        End If
        rgData.AdvancedFilter xlFilterCopy, rCrit, tmp
        rgData.EntireColumn.Copy
        tmp.PasteSpecial Paste:=xlPasteColumnWidths
        
    
   ' اظافة ارتباط تشعبي لاوراق المجوعات الحرفية
    Worksheets(srcWS.Name).Hyperlinks.Add Anchor:=Worksheets(srcWS.Name).[E2], Address:="", _
    SubAddress:="'" & WS.Name & "'" & "!A1", TextToDisplay:="ورقةالبيانات"
    lastRow = srcWS.Columns("A:C").Find(What:="*", SearchDirection:=xlPrevious, _
                                          SearchOrder:=xlByRows).Row
                                              
    '***(ازالة التكرار في حالة وجوده (على الاوراق الجديدة ***
    'الاعمدة
     d = [{1,2,3}]
     srcWS.Range(srcWS.Cells(1, 1), srcWS.Cells(lastRow, 3)).RemoveDuplicates d(1), Header:=xlNo
     ' اعادة ترتيب التسلسل
       With srcWS.Range("A2:A" & srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row)
          .Formula = "=IF(B2="""","""",IF(B2=""Name"",""Count"",N(A1)+1))"
          .Value = .Value
           End With
   Next Cpt
rCrit.EntireColumn.Clear
' تحديد اوراق المجموعات الحرفية
For x = 1 To Sheets.Count
  nf = Sheets(x).Name
    If Len(nf) = 1 Or (nf) Like "*-*" Then
    Sheets(x).Activate

With ActiveSheet
'عدد الاسماء على كل ورقة
lige = Evaluate("SUM(0+(A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row & "<>""""))")
 ' اظافة الارتباط التشعبي لجميع الاوراق الى الرئيسية
      WS.Hyperlinks.Add Anchor:=WS.Cells(x + 2, 10), Address:="", SubAddress:="'" & _
      nf & "'" & "!A1", TextToDisplay:="حرف" & "-" & nf
    .Tab.Color = 5287936: [A1].Select: .DisplayRightToLeft = True: .[f1] = "عدد الاسماء": .[f2] = lige
  End With
     ' استخراج اسماء  المجموعات الحرفية
        nams = nams & "   " & "حرف" & "-" & nf
        nCount = nCount + 1
    End If
  Next x
  ' ترتيب ابجدي لاسماء الشيتات
Irow = WS.Range("j:j").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
WS.Range("j2:j" & Irow).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
WS.Range("j1:j" & Irow).Sort Key1:=WS.[j2], _
Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
                                              Orientation:=xlTopToBottom
    WS.Activate
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .CalculateFull
  End With
     MsgBox nams, vbInformation, "تم حفظ" & " : " & nCount & " " & "مجموعة بنجاح"
End Sub

 اما لطلبك لحفظ الملفات بصيغة PDF

تفضل اخي

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

 

Sub Save_PDF()
Dim wb As Workbook, _
              WS As Variant, _
         lastRow As Long, _
nCount As Integer, strFolder As String
    Const File_format As String = ".pdf"
 
 ' قم بتعديل اسم مجلد الحفظ بما يناسبك
 strFolder = "المجموعات الحرفية"

Set wb = ActiveWorkbook:
With Application
        .ScreenUpdating = False

If MsgBox("؟" & " PDF" & " : " & " حفط الملفات ", vbYesNo) = vbNo Then Exit Sub
For Each WS In wb.Worksheets
    If Len(WS.Name) = 1 Or (WS.Name) Like "*-*" Then
    Cpt = True
    j = "حرف" & "-" & WS.Name
 nCount = nCount + 1
lastRow = WS.Columns("A:C").Find(What:="*", SearchDirection:=xlPrevious, _
                                         SearchOrder:=xlByRows).Row
 With wb
  On Error Resume Next
        SaveLocation = wb.Path & Application.PathSeparator & strFolder
        If Len(Dir(SaveLocation, vbDirectory)) = 0 Then
        End If
        MkDir SaveLocation
   End With
   ' الاعدادات
  With WS.PageSetup
        .PrintArea = "$A$1:$C$" & lastRow
        .PrintTitleRows = "$1:$1"
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlLandscape
        .CenterFooter = j
    End With
WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=SaveLocation & Application.PathSeparator & j & File_format, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End If
  Next WS
  .ScreenUpdating = True
End With

If Cpt = False Then
MsgBox "لا توجد ملفات للحفظ", vbInformation, "تم إلغاء الإجراء": Exit Sub
End If

     MsgBox "تم حفظ" & " : " & nCount & " " & "مجموعة بنجاح", _
        vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, SaveLocation
End Sub

 

 

 

 

ترحيل الاسماء حسب الاحرف الى شيتات V3.xlsm

تم تعديل مايو 9 بواسطه محمد هشام.

[kkfhvvv]

السلام عليكم

جزاك الله عنا خيرا

الكود 100 %

قام بالمطلوب

شاكرين جهودكم وبارك الله لكم في وقتكم