تفکیک لغات براساس حرف اول

**shamsololama** · 2016/05/02, 11:45

با درود فراوان
نمی دانم چرا قست دارید به این صورت حروف ها رو در شیت های مختلف جدا کنید در هر صورت بر حسب نیاز شما اگر بخواهید اینکار رو انجام بدین
با ایجاد یک حلقه که اطلاعات شیت اصلی را بخواند و لفت لغات با یک کاراکتر را بررسی کند و اگر a بودی شیتی به نام a ایجاد کند و لغات را در آن درج کند و اگر حرف اول ان B بود شیتی به نام بی را در ایجاد کند و زمان ایجاد شیت هم بررسی کند اگر شیتی به نام این حرف وجود نداشت ایجاد کند در غیر اینصورت در همان شیت لغت را درج کند تا انتهای حلقه که که تمام لغات را به تفکیک انتقال دهد .

**sunstar** · 2016/05/02, 14:13

استاد بزرگوار ، اطلاعات ویژوال من خیلی کمه ، اگه مرحمت کنید نمونه فایلی هم بذارید که اطلاعات این حقیر رو بالا ببره ، خیلی سپاسگذار میشم . بی نهایت ممنون

**shamsololama** · 2016/05/02, 17:17

نوشته اصلی توسط sunstar

سلام علیکم براساتید گرامی
من یک شیت دارم که ستون a لغات انگلیسی و ستون b معانی لغات در مقابل هر سل درج شده است اگر بخواهیم کدی بنویسیم که شیت مذکور براساس حرف اول لغات تفکیک بشود یعنی ؛ بدون تغییر در اطلاعات شیت اصلی ، اگر در بین لغات شیت اصلی لغتی وجود دارد که با حرف a شروع شده است در اینصورت یک شیت جدید با نام a ایجاد و لغاتی که حرف اول آنها با a شروع می شود در آن شیت درج گردد و اگر در بین لغات شیت اصلی لغتی وجود دارد که با حرف b شروع شده است شیت جدید با نام b ایجاد و لغاتی که حرف اول آنها با b شروع می شود در آن صفحه درج گردد و الی آخر...
هزاران سپاس

کد:

Sub Macro1()
'
' shamsololama
Dim c As Range, lcname, shnam
Dim g As Range
For Each c In Sheet1.Range("A3:A10000")
    If c.Value <> "" Then
      lcname = Left(Trim(c.Value), 1)
 '/////////////////////
        Dim sh As Worksheet, flg As Boolean
        shnam = False
        For Each sh In Worksheets
        If LCase(sh.Name) = LCase(lcname) Then shnam = True: Exit For
        Next
        
        If shnam <> True Then
           Sheets.Add.Name = UCase(lcname)
           
        End If
'\\\\\\\\\\\\\\\\\\\\\\\
        For Each g In Sheets(lcname).Range("A2:A10000")
            If g.Value = "" Then
                g.Value = c.Value
                g.Offset(0, 1).Value = c.Offset(0, 1).Value
                Exit For
            End If
         Next
        
    End If




Next
End Sub

فایل نمونه :

فایل های پیوست شده