جدا کردن اسم افراد از شماره موبایل

[adelparsa]

سلام دوستان عزیز
من یک فایل اکسل دارم که حاوی 22 شیت هست . در هر شیت یه سری اطلاعات هست و ستون d هر شیت مربوط به شماره موبایل افراد هست . کنار شماره تلفن اسم فامیل فرد رو داخل پرانتز نوشته شده و بعضی از سلول ها هم 2 تا شماره موبایل داره.
الان میخوام یک ستون کنار d ایجاد کنم و که فقط شماره موبایل افراد داخلش باشه و دیگه اسم نباشه ( میخوام با این شماره ها لیست دفتر تلفن درست کنم اصلا هم نام افراد مهم نیست که پاک بشه فقط میخوام شماره موبایل ها رو توی یک ستون مجزا داشته باشم )
فایل مذکور رو هم پیوست کردم .
دوستان اگه میتونن کمک کنن.
در ضمن من اطلاعات برنامه نویسی ندارم اگه میشه توی فای برام اصلاح کنید.
ممنون

[iranweld]

با سلام

فعلا شماره موبایلها از اسم جدا گردید چنانچه تمایل دارید هر شماره در یک سلول قرار گیرد اطلاع دهید

Sub test3()

Dim employee As String, total As Integer, sheet As Worksheet, i, j, y As Integer, rng As Range

For Each sheet In Worksheets
sheet.Select

k = Cells(Rows.Count, "d").End(xlUp).Row

For j = 2 To k

OutValue = ""

    xValue = Range("d" & j).Value
    
    For i = 1 To Len(xValue)
    
        If IsNumeric(Mid(xValue, i, 1)) Then
        
            OutValue = OutValue & Mid(xValue, i, 1)
            
            If Not IsNumeric(Mid(xValue, i + 1, 1)) Then
            OutValue = OutValue & " "
            
            End If
            
           
        End If
        
        
        Next
        
        Range("j" & j).Value = OutValue
        
        Next
        
        Next

End Sub 

[adelparsa]

خیلی ممنونم ازتون
بله اگه امکانش هست هر شماره موبایل رو داخل یک سلول قرار بدید.
باز هم تشکر میکنم

[khakzad]

شما براحتی با استفاده از ابزار Find این کار و انجام بدید



کلفیه داخل پرانتز رو با هیچی جایگزین کنید

[iranweld]

خیلی ممنونم ازتون
بله اگه امکانش هست هر شماره موبایل رو داخل یک سلول قرار بدید.
باز هم تشکر میکنم

با سلام

ماکرو اصلاح گردید

Sub test3()

Dim sheet As Worksheet, i, j, y As Integer

For Each sheet In Worksheets

sheet.Select

Columns("J:R").NumberFormat = "@"

k = Cells(Rows.Count, "d").End(xlUp).Row

For j = 1 To k

k1 = 10

OutValue = ""

    xValue = Range("d" & j).Value
    
    For i = 1 To Len(xValue)
    
        If IsNumeric(Mid(xValue, i, 1)) Then
        
            OutValue = OutValue & Mid(xValue, i, 1)
            
            If Not IsNumeric(Mid(xValue, i + 1, 1)) Then
            
            Cells(j, k1).Value = OutValue
            
            OutValue = ""
            
            k1 = k1 + 1
            
            End If
            
           
        End If
        
        
    Next: Next: Next
        
        Sheet1.Select

End Sub 

[adelparsa]

بسیارمتشکرم عالی بود
ممنون