Copying cell from one sheet and splitting it into two cells in second sheet.

I'm much more familiar with Access but this project demands using Excel. This may be a simple solution but will throw out the problem anyway.

I have a database with multiple sheets. On sheet1, in column G are phone numbers, some with labels after the end (i.e.: 333-444-5555c), some with no labels (i.e. 222-333-4444).

In sheet 2, in column G, I want to fill the column with only the phone numbers (no labels) using VBA code. I can autofill the column using (Range("G2:G" & lRow).Formula = "=G2") but that fills the entire row with the labels as well. I also want to autofill column H in sheet2 with the labels. To further muddy the issue, I would like to fill column H on sheet 2, not with just the label (i.e. c), but to spell out what the label is (i.e. if "c" then fill it with "cellular" or if "h" then fill it with "home" and so on).

I've tried (erased the code because it wasn't working so I can't share it) something along these lines:
Dim Phone1Len As Long
Dim Phone1Kind As Long
Phone1Len = Len(Sheets("Sheet1").Range("G2")) *Note: this gives me a correct length of the cell

This is where I've ran into issues. I want to now find the data after the 12th character in the cell from Sheet1, cell G2. I've tried:
Phone1Kind = "=Right(Sheets("Imported Raw Data"), (G2), (Phone1Len) - 12)"

I'll stop here for now as I think I have most of the rest figured out, but have had issues with the above sentence.

Thanks in advance
Jeffrey VogelzangAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Hi Jeffrey,

Please give this a try...

Sub FillPhoneNumberAndLabels()
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long

With Application
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set sws = Sheets("Sheet1")
Set dws = Sheets("Sheet2")

lr = sws.Cells(Rows.Count, "G").End(xlUp).Row
dws.Range("G2:G" & lr).Formula = "=GetPhoneNumber(" & sws.Name & "!G2)"
dws.Range("G2:G" & lr).Value = dws.Range("G2:G" & lr).Value

dws.Range("H2:H" & lr).Formula = "=getLabel(" & sws.Name & "!G2)"
dws.Range("H2:H" & lr).Value = dws.Range("H2:H" & lr).Value

With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
End With

End Sub


Function GetPhoneNumber(ByVal rng As Range)
Dim RE As Object, Matches As Object
Set RE = CreateObject("VBScript.RegExp")
With RE
   .Global = False
   .Pattern = "\d{3}-\d{3}-\d{4}"
End With
If RE.test(rng.Value) Then
   Set Matches = RE.Execute(rng.Value)
   GetPhoneNumber = Matches(0)
End If
End Function

Function getLabel(ByVal rng As Range) As String
Dim RE As Object, Matches As Object
Dim Label As String
Dim dict
Set RE = CreateObject("VBScript.RegExp")
With RE
    .Global = False
    .Pattern = "\d{3}-\d{3}-\d{4}"
End With

Set dict = CreateObject("Scripting.Dictionary")

'You may add description for more Labels here. The Label should be in lower case like "c", "h" etc
With dict
.Add "c", "Cellular"
.Add "h", "Home"
End With

If RE.test(rng.Value) Then
    Set Matches = RE.Execute(rng.Value)
    Label = Trim(LCase(Replace(rng, Matches(0), "")))
    If dict.exists(Label) Then
        getLabel = dict.Item(Label)
    End If
End If
End Function

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
NorieAnalyst Assistant Commented:
Are the phone numbers always XXX-XXX-XXXX?

If they are to get only the number in column G on Sheet2 you can use this.
Range("G2:G" & lRow).Formula = "=LEFT(Sheet1!G2,12)"

Open in new window

To get the label, if there is one, you can use this.
Range("H2:H" & lRow).Formula = "=IFERROR(MID(Sheet1!H2,13,1),"""")"
 

Open in new window

NorieAnalyst Assistant Commented:
Here's another version of the second formula that returns Cellular/Home.
Range("H2:H" & lRow).Formula = "=IFERROR(INDEX({""Cellular"",""Home""},,MATCH(MID(Sheet1!G2,13,1),{""c"",""h"",0})),"""")"

Open in new window

Just for good luck, here's another.
Range("H2:H" & lRow).Formula "=IFERROR(CHOOSE(SEARCH(MID(Sheet1!G2,13,1),""ch""),""Cellular"", ""Home""), """")"

Open in new window

Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

Rossano PraderiIT ConsultantCommented:
This question have many possible solutions, this is my contribute.

Sub PhoneNumbers()
Dim Sh2 As Worksheet
Dim rc As Long, i As Long
Dim v As String, l As String

Set Sh2 = Sheets("Sheet2")

With ThisWorkbook.Worksheets("Sheet1")

rc = .Cells(Rows.Count, "G").End(xlUp).Row
For i = 1 To rc
    v = .Range("G" & i).Value:    l = VBA.Right(v, 1)
    Sh2.Range("G" & i).Value = VBA.Left(v, IIf((l = "h" Or l = "c"), VBA.Len(v) - 1, VBA.Len(v)))
    Sh2.Range("H" & i).Value = IIf(l = "c", "CellPhone", IIf(l = "h", "Home", ""))
Next
End With
Set Sh2 = Nothing
End Sub

Open in new window

Jeffrey VogelzangAuthor Commented:
First of all, thank you three for responding.

I am trying Subodh Tiwari (Neeraj)'s code first.  In running the code, the Open Folder dialog opens with the header: "Update Values: Data". Is this where the phone label codes are to be stored? I can select the file I'm working on and then it asks me to select the sheet where to update the values from.

Can you help me with this?
NorieAnalyst Assistant Commented:
Jeffrey

What are your sheets actually called?

I think we've all assumed they are named Sheet1 and Sheet2.

If that's not the case then that could be the reason you get the prompt you describe.
Rossano PraderiIT ConsultantCommented:
Jeffrey, can you share a sample file?
Rossano PraderiIT ConsultantCommented:
This is an update with variable sheet names.

Sub PhoneNumbers(sn1 As String, sn2 As String)
' sn1 is the name of the sheet which contain the original list
' sn2 is the name of the destination sheet
Dim Sh2 As Worksheet
Dim rc As Long, i As Long
Dim v As String, l As String

Set Sh2 = Sheets(sn2)

With ThisWorkbook.Worksheets(sn1)

rc = .Cells(Rows.Count, "G").End(xlUp).Row
For i = 1 To rc
    v = .Range("G" & i).Value:    l = VBA.Right(v, 1)
    Sh2.Range("G" & i).Value = VBA.Left(v, IIf((l = "h" Or l = "c"), VBA.Len(v) - 1, VBA.Len(v)))
    Sh2.Range("H" & i).Value = IIf(l = "c", "CellPhone", IIf(l = "h", "Home", ""))
Next
End With
Set Sh2 = Nothing
End Sub

Sub runMacro()
    PhoneNumbers "Sheet1", "Sheet2"
End Sub

Open in new window

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
In my code look at the lines# 11 and 12.
Those two lines assume that the workbook has two sheets called Sheet1 and Sheet2 where Sheet1 is the source sheet which contains the phone numbers with label and Sheet2 is the destination sheet where the phone numbers and the labels are placed in column G and H.

Change the Sheet names as per your workbook in those two lines.

The open folder dialog box opens just because the formula which is being placed on the sheet contains a sheet name which is not present in your workbook. After changing the sheet names, the code will work fine.
Jeffrey VogelzangAuthor Commented:
I found the error on my part to why I was getting that dialog. In my original question, in my mind I thought it was columns G & H in sheet2, but rather it was columns R & S. I forgot to change these in one spot in the code provided.

I no longer get the dialog boxes, but the columns show "#VALUE!".

Thanks again for your patience and help.
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
In that case all you need is to change replace these lines...

dws.Range("G2:G" & lr).Formula = "=GetPhoneNumber(" & sws.Name & "!G2)"
dws.Range("G2:G" & lr).Value = dws.Range("G2:G" & lr).Value

dws.Range("H2:H" & lr).Formula = "=getLabel(" & sws.Name & "!G2)"
dws.Range("H2:H" & lr).Value = dws.Range("H2:H" & lr).Value

Open in new window


WITH

dws.Range("R2:R" & lr).Formula = "=GetPhoneNumber(" & sws.Name & "!G2)"
dws.Range("R2:R" & lr).Value = dws.Range("R2:R" & lr).Value

dws.Range("S2:S" & lr).Formula = "=getLabel(" & sws.Name & "!G2)"
dws.Range("S2:S" & lr).Value = dws.Range("S2:S" & lr).Value

Open in new window

Rossano PraderiIT ConsultantCommented:
Ok, new update with dynamic sheet names and column names.

Sub PhoneNumbers(sn1 As String, sn2 As String, CF As String, CT As String)
' sn1 is the name of the sheet which contain the original list
' sn2 is the name of the destination sheet
' CF column from which contain the original list
' CT column where to start
Dim Sh2 As Worksheet
Dim rc As Long, i As Long
Dim v As String, l As String
Dim vCol

Set Sh2 = Sheets(sn2)

With ThisWorkbook.Worksheets(sn1)

vCol = VBA.Split(.Cells(1, .Range(CT & 1).Column + 1).Address(True, False), "$")
rc = .Cells(Rows.Count, CF).End(xlUp).Row
For i = 1 To rc
    v = .Range(CF & i).Value:    l = VBA.Right(v, 1)
    Sh2.Range(CT & i).Value = VBA.Left(v, IIf((l = "h" Or l = "c"), VBA.Len(v) - 1, VBA.Len(v)))
    Sh2.Range(vCol(0) & i).Value = IIf(l = "c", "CellPhone", IIf(l = "h", "Home", ""))
Next
End With
Set Sh2 = Nothing
End Sub

Sub runMacro()
    PhoneNumbers "Sheet1", "Sheet2", "G", "S"
End Sub

Open in new window

Jeffrey VogelzangAuthor Commented:
My code is as follows:

Sub EditCompileData()

Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet, sh5 As Worksheet
Dim lRow As Long
Dim lCol As Long
Dim iCounter As Long

Set sh1 = Sheets("Imported Raw Data")
Set sh2 = Sheets("Manipulated Data to Fit MN Book")
'Set sh3 = Sheets()
'Set sh4 = Sheets()
'Set sh5 = Sheets()

' RemoveBlankRows Macro:

With Application
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .ScreenUpdating = False
    For iCounter = Selection.Rows.Count To 1 Step -1
        If WorksheetFunction.CountA(Selection.Rows(iCounter)) = 0 Then
            Selection.Rows(iCounter).EntireRow.Delete
        End If
    Next iCounter
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With

'Copy the data from "Imported Raw Data" to "Manipulated Data to Fit MN Book"

'Find last row with data'
 lRow = Cells.Find("*", Range("A1"), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
 
'Clear the "Manipulated Data to Fit MN Book" sheet
  sh2.Range("A2:BB" & lRow).Clear
 
 'Selection.SpecialCells(xlCellTypeConstants, 23).Select
 'Selection.ClearContents
   
'Copy Field Name
    sh1.Range("A2:A" & lRow).Copy Destination:=sh2.Range("A2")
'Copy Meeting Name
    sh1.Range("B2:B" & lRow).Copy Destination:=sh2.Range("B2")
'Copy Last Name
    sh1.Range("C2:C" & lRow).Copy Destination:=sh2.Range("I2")
'Copy First Name
    sh1.Range("D2:D" & lRow).Copy Destination:=sh2.Range("J2")
'Copy Spouse Name
    sh1.Range("E2:E" & lRow).Copy Destination:=sh2.Range("K2")
'Copy Children's Names
    sh1.Range("F2:F" & lRow).Copy Destination:=sh2.Range("P2")
'Copy Phone Number 1 Data
    sh1.Range("G2:G" & lRow).Copy Destination:=sh2.Range("Q2")
'Copy Phone Number 2 Data
    sh1.Range("H2:H" & lRow).Copy Destination:=sh2.Range("T2")
'Copy Phone Number 3 Data
    sh1.Range("I2:I" & lRow).Copy Destination:=sh2.Range("W2")
'Copy Phone Number 4 Data
    sh1.Range("J2:J" & lRow).Copy Destination:=sh2.Range("Z2")
'Copy Phone Number 5 Data
    sh1.Range("K2:K" & lRow).Copy Destination:=sh2.Range("AC2")
'Copy Phone Number 6 Data
    sh1.Range("L2:L" & lRow).Copy Destination:=sh2.Range("AF2")
'Copy Steet Address Data
    sh1.Range("O2:O" & lRow).Copy Destination:=sh2.Range("AK2")
'Copy City Data
    sh1.Range("Q2:Q" & lRow).Copy Destination:=sh2.Range("AN2")
'Copy State Data
    sh1.Range("R2:R" & lRow).Copy Destination:=sh2.Range("AO2")
'Copy Zip Data
    sh1.Range("S2:S" & lRow).Copy Destination:=sh2.Range("AP2")
'Copy Union Meeting Home Data
    sh1.Range("T2:T" & lRow).Copy Destination:=sh2.Range("AS2")
'Copy Notes
    sh1.Range("U2:U" & lRow).Copy Destination:=sh2.Range("AU2")
'Copy GPS Coordinates
    sh1.Range("AB2:AB" & lRow).Copy Destination:=sh2.Range("AW2")
'Copy DMS
    sh1.Range("AG2:AG" & lRow).Copy Destination:=sh2.Range("AX2")
'Create Formulated Columns
        'Fill Orginazation Name
            sh2.Range("D2:D" & lRow).Formula = "=A2&""/""&B2"
           
        'Fill Given Name
            sh2.Range("M2:M" & lRow).Formula = "=IF(K2="""",J2,J2&"" & ""&K2)"
       
        'Fill Family Name
            sh2.Range("N2:N" & lRow).Formula = "=I2"
                       
        'Fill Name
            sh2.Range("O2:O" & lRow).Formula = "=M2&"" ""&N2"
           
        'Fill Phone 1 Value
            sh2.Range("R2:R" & lRow).Formula = "=GetPhoneNumber(" & sh1.Name & "!G2)"
            sh2.Range("R2:R" & lRow).Value = sh2.Range("R2:R" & lRow).Value
           
        'Fill PHone 1 Type
            sh2.Range("S2:S" & lRow).Formula = "=getLabel(" & sh1.Name & "!G2)"
            sh2.Range("S2:S" & lRow).Value = sh2.Range("S2:S" & lRow).Value
 
With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True

End With

End Sub

Function GetPhoneNumber(ByVal rng As Range)
Dim RE As Object, Matches As Object
Set RE = CreateObject("VBScript.RegExp")
With RE
   .Global = False
   .Pattern = "\d{3}-\d{3}-\d{4}"
End With
If RE.test(rng.Value) Then
   Set Matches = RE.Execute(rng.Value)
   GetPhoneNumber = Matches(0)
End If
End Function

Function getLabel(ByVal rng As Range) As String
Dim RE As Object, Matches As Object
Dim Label As String
Dim dict
Set RE = CreateObject("VBScript.RegExp")
With RE
    .Global = False
    .Pattern = "\d{3}-\d{3}-\d{4}"
End With

Set dict = CreateObject("Scripting.Dictionary")

'You may add description for more Labels here. The Label should be in lower case like "c", "h" etc
With dict
.Add "c", "Cellular"
.Add "h", "Home"
.Add "nh", "Nursing Home"
.Add "lk", "Lake"
.Add "cab", "Cabin"
.Add "f", "Fax"
.Add "w", "Work"
.Add "b", "Business"

End With

If RE.test(rng.Value) Then
    Set Matches = RE.Execute(rng.Value)
    Label = Trim(LCase(Replace(rng, Matches(0), "")))
    If dict.exists(Label) Then
        getLabel = dict.Item(Label)
    End If
End If
End Function
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Change the formula lines as below and see if that works for you. If not, please upload a small sample workbook to work with.

dws.Range("R2:R" & lr).Formula = "=GetPhoneNumber('" & sh1.Name & "'!G2)"
dws.Range("R2:R" & lr).Value = dws.Range("R2:R" & lr).Value

dws.Range("S2:S" & lr).Formula = "=getLabel('" & sh1.Name & "'!G2)"
dws.Range("S2:S" & lr).Value = dws.Range("S2:S" & lr).Value

Open in new window

Jeffrey VogelzangAuthor Commented:
Those extra single quotation marks were the missing piece to the puzzle.

Thank you so very much for your help...all of you.
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome Jeffrey!
Yes, the single quotes are required if the sheet name has spaces in it. :)
Jeffrey VogelzangAuthor Commented:
In your code for the list of labels, you mention that the label should be in lower case. Why is that? Or could it be in upper case?

And sorry for not seeing how to post code earlier. I see how to do it now!
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
I said that to maintain a pattern which helps in the code. All you need is to add the abbreviated label in lower case though it will work if the phone numbers contain the labels in upper case as well.

No problem. Posting the code within the code tags makes it easy to read.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.