Unconcatenate and Replace Text

  • Thread starter Thread starter crystalgatewood
  • Start date Start date
C

crystalgatewood

Hi all and thanks in advance.

I have two files. File1 has codes and full text in two columns.
Example:
1st column 2nd column
app Application Server
edb1c Data Base Server 1

File2 has a column called "Platforms". (It is the fourth column in the
5-column sheet.) In that column, the data is grouped and separated by
semi-colons.
Example:
Platforms
app;edb1c;edb2c;nbu01;nr1tms1

I need to write a macro to use on File2 that will replace all instances
of the codes with the full text that the code stands for - by reading
the other sheet or not. (I'm not sure if this replace list can be
loaded in a macro.) I also need to create a separate line for each of
the decoded platforms. (Not all 5 columns have to be repeated, but
that's OK too.) The unconcatenate and the replace can be done in either
order or in separate macros.

Any assistance you can give me on this will be greatly appreciated.

Crystal
 
So if the code isn't translated, you don't need that row created?

If yes, then this worked for me. (I did put the worksheets into a single
workbook for testing. But you could point to whatever sheet in whatever
workbook you want.)

Option Explicit
Sub testme()
Dim WksPOrig As Worksheet
Dim WksTemp As Worksheet
Dim WksPFinal As Worksheet
Dim WksTable As Worksheet
Dim myTableRng As Range
Dim myCell As Range
Dim res As Variant
Dim LastRow As Long
Dim iRow As Long
Dim iCol As Long
Dim oRow As Long

Dim myArray() As Variant
Dim iCtr As Long
Dim maxFields As Long

maxFields = 100 '100 platforms in that cell??

ReDim myArray(1 To maxFields, 1 To 2)
For iCtr = 1 To maxFields
myArray(iCtr, 1) = iCtr
myArray(iCtr, 2) = 1
Next iCtr

'copy the original Platform sheet
Set WksPOrig = Worksheets("Sheet1")
WksPOrig.Copy _
after:=WksPOrig
Set WksTemp = ActiveSheet

Set WksTable = Worksheets("sheet2")

With WksTable
Set myTableRng = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
End With

With WksTemp
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row

.Range("d1").EntireColumn.Cut
.Range("F1").EntireColumn.Insert Shift:=xlToRight

.Range("E2", .Cells(.Rows.Count, "E").End(xlUp)) _
.TextToColumns Destination:=.Range("E2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=True, Comma:=False, _
Space:=False, Other:=False, _
FieldInfo:=myArray

For Each myCell In myTableRng.Cells
With .Range("E2:IV" & LastRow)
.Replace what:=myCell.Value, _
replacement:=myCell.Offset(0, 1).Value, _
lookat:=xlWhole, searchorder:=xlByRows, MatchCase:=False
End With
Next myCell

'create the final home for the data
Set WksPFinal = Worksheets.Add
WksPFinal.Range("a1").Resize(1, 5).Value _
= WksPOrig.Range("a1").Resize(1, 5).Value

oRow = 1
For iRow = 2 To LastRow
For iCol = 5 To .Cells(iRow, .Columns.Count).End(xlToLeft).Column
res = Application.Match(.Cells(iRow, iCol).Value, _
myTableRng.Offset(0, 1), 0)
If IsError(res) Then
'not translated/converted, do nothing???
Else
oRow = oRow + 1
WksPFinal.Cells(oRow, "A").Resize(1, 3).Value _
= .Cells(iRow, "A").Resize(1, 3).Value
WksPFinal.Cells(oRow, "D").Value = .Cells(iRow, iCol).Value
WksPFinal.Cells(oRow, "E").Value = .Cells(iRow, "D").Value
End If
Next iCol
Next iRow
End With

Application.DisplayAlerts = False
WksTemp.Delete
Application.DisplayAlerts = True
End Sub

If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm
 
Thank you, thank you, thank you Dave!

Unfortunately, I do need to spit out the code that was not translated
on a separate line as well. So I'm trying to work that out in/near the
Replace loop. Right now, it's searching the whole Platform sheet,
going back to the top, then adding the top code full text value for the
ones that are not found.

I do have another issue. I have an entry in one of the columns that is
supposed to be numbers read as text.
Example:
'04/02

When this value gets moved to the new sheet, it is interpreted as a
date. It seems the ' is being ignored or lost in the move. Any ideas?

Crystal
 
Maybe this one:

Option Explicit
Sub testme2()
Dim WksPOrig As Worksheet
Dim WksTemp As Worksheet
Dim WksPFinal As Worksheet
Dim WksTable As Worksheet
Dim myTableRng As Range
Dim myCell As Range
Dim res As Variant
Dim LastRow As Long
Dim iRow As Long
Dim iCol As Long
Dim oRow As Long

Dim myArray() As Variant
Dim iCtr As Long
Dim maxFields As Long

maxFields = 100 '100 platforms in that cell??

ReDim myArray(1 To maxFields, 1 To 2)
For iCtr = 1 To maxFields
myArray(iCtr, 1) = iCtr
myArray(iCtr, 2) = 1
Next iCtr

'copy the original Platform sheet
Set WksPOrig = Worksheets("Sheet1")
WksPOrig.Copy _
after:=WksPOrig
Set WksTemp = ActiveSheet

Set WksTable = Worksheets("sheet2")

With WksTable
Set myTableRng = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
End With

With WksTemp
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row

.Range("d1").EntireColumn.Cut
.Range("F1").EntireColumn.Insert Shift:=xlToRight

.Range("E2", .Cells(.Rows.Count, "E").End(xlUp)) _
.TextToColumns Destination:=.Range("E2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=True, Comma:=False, _
Space:=False, Other:=False, _
FieldInfo:=myArray

For Each myCell In myTableRng.Cells
With .Range("E2:IV" & LastRow)
.Replace what:=myCell.Value, _
replacement:=myCell.Offset(0, 1).Value, _
lookat:=xlWhole, searchorder:=xlByRows, MatchCase:=False
End With
Next myCell

'create the final home for the data
Set WksPFinal = Worksheets.Add
WksPFinal.Range("a1").Resize(1, 5).Value _
= WksPOrig.Range("a1").Resize(1, 5).Value

oRow = 1
For iRow = 2 To LastRow
For iCol = 5 To .Cells(iRow, .Columns.Count).End(xlToLeft).Column
'res = Application.Match(.Cells(iRow, iCol).Value, _
myTableRng.Offset(0, 1), 0)
res = "Ok"
If IsError(res) Then
'not translated/converted, do nothing???
Else
oRow = oRow + 1
'do columns A:C
For iCtr = 1 To 3
With WksPFinal.Cells(oRow, iCtr)
.NumberFormat = .Cells(iRow, iCtr).NumberFormat
.Value = .Value
End With
Next iCtr
'column D
With WksPFinal.Cells(oRow, "D")
.NumberFormat = .Cells(iRow, iCol).NumberFormat
.Value = .Value
End With
'column E
With WksPFinal.Cells(oRow, "E")
.NumberFormat = .Cells(iRow, "D").NumberFormat
.Value = .Cells(iRow, "D").Value
End With
End If
Next iCol
Next iRow
End With

Application.DisplayAlerts = False
WksTemp.Delete
Application.DisplayAlerts = True
End Sub

I cheated by just changing that res variable to a constant (Ok) instead of
looking for a match.

And it still does things cell by cell--that could be improved on, but this was
an easy change <vbg>.
 
Dave - Thanks again, but I'd already figured something out (and I fixed
that text/date conversion problem as well):

Option Explicit
Sub testme()
Dim WksPOrig As Worksheet
Dim WksTemp As Worksheet
Dim WksPFinal As Worksheet
Dim WksTable As Worksheet
Dim myTableRng As Range
Dim myCell As Range
Dim holdCell As Range
Dim res As Variant
Dim LastRow As Long
Dim iRow As Long
Dim iCol As Long
Dim oRow As Long

Dim myArray() As Variant
Dim iCtr As Long
Dim maxFields As Long

maxFields = 100 '100 platforms in that cell??

ReDim myArray(1 To maxFields, 1 To 2)
For iCtr = 1 To maxFields
myArray(iCtr, 1) = iCtr
myArray(iCtr, 2) = 1
Next iCtr

'copy the original Platform sheet
Set WksPOrig = Worksheets("Sheet1")
WksPOrig.Copy _
after:=WksPOrig
Set WksTemp = ActiveSheet

Set WksTable = Worksheets("sheet2")

With WksTable
Set myTableRng = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
End With

With WksTemp
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row

Range("D1").EntireColumn.Cut
Range("F1").EntireColumn.Insert Shift:=xlToRight

Range("E2", .Cells(.Rows.Count, "E").End(xlUp)) _
TextToColumns Destination:=.Range("E2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=True, Comma:=False, _
Space:=False, Other:=False, _
FieldInfo:=myArray

For Each myCell In myTableRng.Cells
With .Range("E2:IV" & LastRow)
Replace what:=myCell.Value, _
replacement:=myCell.Offset(0, 1).Value, _
lookat:=xlWhole, searchorder:=xlByRows, MatchCase:=False
End With
Next myCell

'create the final home for the data
Set WksPFinal = Worksheets.Add
WksPFinal.Range("a1").Resize(1, 5).Value _
= WksPOrig.Range("a1").Resize(1, 5).Value

oRow = 1
For iRow = 2 To LastRow
For iCol = 5 To .Cells(iRow, .Columns.Count).End(xlToLeft).Column
res = Application.Match(.Cells(iRow, iCol).Value, _
myTableRng.Offset(0, 1), 0)
If IsError(res) Then
'not found in Platform table
'not converted, just copy original row with Not Found message

oRow = oRow + 1
WksPFinal.Cells(oRow, "A").Resize(1, 3).Value _
= .Cells(iRow, "A").Resize(1, 3).Value
WksPFinal.Cells(oRow, "D").Value = "NOT FOUND (" & .Cells(iRow,
iCol).Value & ")"
WksPFinal.Cells(oRow, "E").Value = .Cells(iRow, "D").Value

Else
oRow = oRow + 1
WksPFinal.Cells(oRow, "B").NumberFormat = "@"
WksPFinal.Cells(oRow, "A").Resize(1, 3).Value _
= .Cells(iRow, "A").Resize(1, 3).Value
WksPFinal.Cells(oRow, "D").Value = .Cells(iRow, iCol).Value
WksPFinal.Cells(oRow, "E").Value = .Cells(iRow, "D").Value
End If
Next iCol
Next iRow
End With

Application.DisplayAlerts = False
WksTemp.Delete
Application.DisplayAlerts = True
End Sub

Thanks again for taking the time to help!

Crystal
 
Glad you got it working with your enhancments.
Dave - Thanks again, but I'd already figured something out (and I fixed
that text/date conversion problem as well):

Option Explicit
Sub testme()
Dim WksPOrig As Worksheet
Dim WksTemp As Worksheet
Dim WksPFinal As Worksheet
Dim WksTable As Worksheet
Dim myTableRng As Range
Dim myCell As Range
Dim holdCell As Range
Dim res As Variant
Dim LastRow As Long
Dim iRow As Long
Dim iCol As Long
Dim oRow As Long

Dim myArray() As Variant
Dim iCtr As Long
Dim maxFields As Long

maxFields = 100 '100 platforms in that cell??

ReDim myArray(1 To maxFields, 1 To 2)
For iCtr = 1 To maxFields
myArray(iCtr, 1) = iCtr
myArray(iCtr, 2) = 1
Next iCtr

'copy the original Platform sheet
Set WksPOrig = Worksheets("Sheet1")
WksPOrig.Copy _
after:=WksPOrig
Set WksTemp = ActiveSheet

Set WksTable = Worksheets("sheet2")

With WksTable
Set myTableRng = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
End With

With WksTemp
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row

Range("D1").EntireColumn.Cut
Range("F1").EntireColumn.Insert Shift:=xlToRight

Range("E2", .Cells(.Rows.Count, "E").End(xlUp)) _
TextToColumns Destination:=.Range("E2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=True, Comma:=False, _
Space:=False, Other:=False, _
FieldInfo:=myArray

For Each myCell In myTableRng.Cells
With .Range("E2:IV" & LastRow)
Replace what:=myCell.Value, _
replacement:=myCell.Offset(0, 1).Value, _
lookat:=xlWhole, searchorder:=xlByRows, MatchCase:=False
End With
Next myCell

'create the final home for the data
Set WksPFinal = Worksheets.Add
WksPFinal.Range("a1").Resize(1, 5).Value _
= WksPOrig.Range("a1").Resize(1, 5).Value

oRow = 1
For iRow = 2 To LastRow
For iCol = 5 To .Cells(iRow, .Columns.Count).End(xlToLeft).Column
res = Application.Match(.Cells(iRow, iCol).Value, _
myTableRng.Offset(0, 1), 0)
If IsError(res) Then
'not found in Platform table
'not converted, just copy original row with Not Found message

oRow = oRow + 1
WksPFinal.Cells(oRow, "A").Resize(1, 3).Value _
= .Cells(iRow, "A").Resize(1, 3).Value
WksPFinal.Cells(oRow, "D").Value = "NOT FOUND (" & .Cells(iRow,
iCol).Value & ")"
WksPFinal.Cells(oRow, "E").Value = .Cells(iRow, "D").Value

Else
oRow = oRow + 1
WksPFinal.Cells(oRow, "B").NumberFormat = "@"
WksPFinal.Cells(oRow, "A").Resize(1, 3).Value _
= .Cells(iRow, "A").Resize(1, 3).Value
WksPFinal.Cells(oRow, "D").Value = .Cells(iRow, iCol).Value
WksPFinal.Cells(oRow, "E").Value = .Cells(iRow, "D").Value
End If
Next iCol
Next iRow
End With

Application.DisplayAlerts = False
WksTemp.Delete
Application.DisplayAlerts = True
End Sub

Thanks again for taking the time to help!

Crystal
Click to expand...
 
I have a list of names that are structured as FFF LLL, I want to split
then into FFF in one call and LLL in another cell. Both mames are
seperated by a single space.

Can you help in developing an unconcantenate?

Thank you
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Code to do a simple clean of one column by copying and pasting(finding and replacing) phrases in adj 4
Comparing and Adding 7
vlookup on different sheet/tab based on stored variable 2
Array Formula in VBA 6
Compare and add 1
I need a VB script for Excel 5
Macro imports data into cols A,B,C. Would like the data in D,E,F 3
Find and Replace 4

Back
Top