poitbot
New Member
- Joined
- Nov 22, 2006
- Messages
- 34
Good morning all!
Hope the humor wasn't too corny.
After a long few weeks of hacking together plenty of scripts I was able to coax excel to extract all my text into a column on a worksheet with all the cell references and worksheet names.
It now looks like this:
Sun, $D$8#Home, $B$42#CBT, $B$3#Common Definitions
Earth, $D$18#Point Summary, $B$3#NE Discounts, $B$42#Classroom Training
Ball, $E$27#Home, $B$4#CBT
The first column being a piece of text to be translated. The second, third, fourth, etc... columns are the cell addresses and worksheets separated by the "#" (Pound) sign.
The macros are as follows(hopefully someone else might find them useful in the future):
The first macro pulls all the text from the multiple spreadsheets and places it in one column on a single worksheet.
The second runs through the worksheet, eliminates duplicates, combines the cell reference and worksheet names and then places these references beside the words.
I was wondering if anyone has a script that would be able to replace all the words in the spreadsheets using the cell references?
As always,
Adam
Hope the humor wasn't too corny.
After a long few weeks of hacking together plenty of scripts I was able to coax excel to extract all my text into a column on a worksheet with all the cell references and worksheet names.
It now looks like this:
Sun, $D$8#Home, $B$42#CBT, $B$3#Common Definitions
Earth, $D$18#Point Summary, $B$3#NE Discounts, $B$42#Classroom Training
Ball, $E$27#Home, $B$4#CBT
The first column being a piece of text to be translated. The second, third, fourth, etc... columns are the cell addresses and worksheets separated by the "#" (Pound) sign.
The macros are as follows(hopefully someone else might find them useful in the future):
The first macro pulls all the text from the multiple spreadsheets and places it in one column on a single worksheet.
Code:
Public Sub texttonewsheet()
Dim n As Long, i As Long
Dim Rng As Range
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
n = 1
For i = 2 To Sheets.Count
For Each Rng In Sheets(i).Range("A1:CI200")
'Checks for text within a cell
If Rng.Value <> "" Then
'If text is detected print text, cell address and worksheet name
If Not Application.IsNumber(Rng) Then
Sheets(1).Range("A" & n).Value = Rng.Value
Sheets(1).Range("B" & n).Value = Rng.Address
Sheets(1).Range("C" & n).Value = Sheets(i).Name
n = n + 1
End If
End If
Next Rng
Next i
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End SubThe second runs through the worksheet, eliminates duplicates, combines the cell reference and worksheet names and then places these references beside the words.
Code:
Option Explicit
Sub Consolidate()
'Column data is Sorted/Matched by column A values, merge all other cells into row format
Dim LastRow As Long, NextCol As Long
Dim LastCol As Long, RW As Long, Cnt As Long
Dim delRNG As Range
Application.ScreenUpdating = False
'Consolidate columns B & C and sort
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A1:C" & LastRow).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
With Range("D1:D" & LastRow)
.FormulaR1C1 = "=RC[-2]&""#""&RC[-1]"
.Value = .Value
End With
Columns("B:C").Delete Shift:=xlToLeft
'Seed the delete range
Set delRNG = Range("A" & LastRow + 10)
'Group matching names
For RW = LastRow To 2 Step -1
If Cells(RW, "A").Value = Cells(RW - 1, "A").Value Then
Range(Cells(RW, "B"), Cells(RW, Columns.Count).End(xlToLeft)).Copy _
Cells(RW - 1, Columns.Count).End(xlToLeft).Offset(0, 1)
Set delRNG = Union(delRNG, Range("A" & RW))
End If
Next RW
'Delete unneeded rows all at once
delRNG.EntireRow.Delete (xlShiftUp)
Set delRNG = Nothing
Cells.Columns.AutoFit
Application.ScreenUpdating = True
End SubI was wondering if anyone has a script that would be able to replace all the words in the spreadsheets using the cell references?
As always,
Adam
