Currently using the following code to loop through a table in Word and merge the cells in the first column where the values are the same:
Dim tbl As Word.Table
Dim cel1 As Word.Cell
Dim cel2 As Word.Cell
Dim rowIndex As Long, colIndex As Long, i As Long, r As Long
Set tbl = ActiveDocument.Tables(1)
colIndex = tbl.Columns.Count
rowIndex = tbl.Rows.Count
For r = 1 To rowIndex - 1
On Error Resume Next
Set cel1 = tbl.Cell(r, 1)
Set cel2 = tbl.Cell(r + 1, 1)
If cel1.Range.Text = cel2.Range.Text Then
cel2.Range.Text = ""
cel1.Merge MergeTo:=cel2
'r = r + 1
End If
Next r
This works well when there is only one table in the document; however, when there are multiple tables, nothing happens. I've tried adding a With, but keeps failing on me.
After looking at this again, realized that I was missing a With statement. Revised code works and looks as follows:
Sub MergeTest()
Dim tbl As Word.Table
Dim cel1 As Word.Cell
Dim cel2 As Word.Cell
Dim rowIndex As Long, colIndex As Long, i As Long, r As Long
Set tbl = ActiveDocument.Tables(1)
colIndex = tbl.Columns.Count
rowIndex = tbl.Rows.Count
For Each tbl In ActiveDocument.Tables
For r = 1 To rowIndex - 1
On Error Resume Next
Set cel1 = tbl.Cell(r, 1)
Set cel2 = tbl.Cell(r + 1, 1)
If cel1.Range.Text = cel2.Range.Text Then
cel2.Range.Text = ""
cel1.Merge MergeTo:=cel2
'r = r + 1
End If
Next r
Next
End Sub
Related
I have a table in a Word document with 3 columns
Using a loop i can see what is in each row
How can i get the value of the current row in Column 2 to show in my message
Here is my code
Dim tbl As Word.Table
Dim rngTable As Range
Set tbl = ActiveDocument.Tables(1)
Set rngTable = ActiveDocument.Range(Start:=celTable.Range.Start, End:=celTable.Range.End - 1)
ColIndex = tbl.Columns.Count
RowIndex = tbl.Rows.Count
For Each tbl In ActiveDocument.Tables
For r = 1 To RowIndex - 1
MsgBox rngTable.Text
Next r
Next
Like this:
Dim tbl As Table, r As Long
Set tbl = ActiveDocument.Tables(1)
For r = 1 To tbl.Rows.Count
MsgBox tbl.Cell(r, 2).Range.Text
Next r
I have a code that works with the selected running text but not working with the selected table cells.
Dim i As Integer
Dim oWords As Words
Dim oWord As Range
Set oWords = Selection.Range.Words
For i = 1 To oWords.Count Step 1
Set oWord = oWords(i)
''Make sure the word range doesn't include a space
Do While oWord.Characters.Last.text = " "
Call oWord.MoveEnd(WdUnits.wdCharacter, -1)
Loop
Debug.Print "'" & oWord.text & "'"
oWord.text = StrReverse(oWord.text)
Next i
I also have the code to extract each cell value but how to modify this to run on selected table cells.
First Code:
Sub Demo()
Dim x As String
Dim i As Integer
Dim j As Integer
Dim Tbl As Table
Set Tbl = ActiveDocument.Tables(1)
For i = 1 To Tbl.Rows.Count
For j = 1 To Tbl.Columns.Count
x = Tbl.Cell(i, j).Range.Text
Next j
Next i
End Sub
Second Code:
Sub testTable()
Dim arr As Variant
Dim intcols As Integer
Dim lngRows As Long
Dim lngCounter As Long
lngRows = ActiveDocument.Tables(1).Rows.Count
intcols = ActiveDocument.Tables(1).Columns.Count
arr = Split(Replace(ActiveDocument.Tables(1).Range.Text, Chr(7), ""), Chr(13))
For rw = 1 To lngRows
For col = 1 To intcols
Debug.Print "Table 1, Row " & rw & ", column " & col; " data is " & arr(lngCounter)
lngCounter = lngCounter + 1
Next
lngCounter = lngCounter + 1
Next
End Sub
Here is code that you should be able to adapt to your purpose.
Sub FindWordsInTableCells()
Dim doc As Word.Document, rng As Word.Range
Dim tbl As Word.Table, rw As Word.Row, cl As Word.Cell
Dim i As Integer, iRng As Word.Range
Set doc = ActiveDocument
For Each tbl In doc.Tables
For Each rw In tbl.rows
For Each cl In rw.Cells
Set rng = cl.Range
rng.MoveEnd Word.WdUnits.wdCharacter, Count:=-1
For i = 1 To rng.words.Count
Set iRng = rng.words(i)
Debug.Print iRng.Text
Next i
Next cl
Next rw
Next tbl
End Sub
If you want to only use cells that are currently selected then use this adaptation of the above routine.
Sub FindWordsInSelectedTableCells()
Dim rng As Word.Range
Dim cl As Word.Cell
Dim i As Integer, iRng As Word.Range
If Selection.Information(wdWithInTable) = True Then
For Each cl In Selection.Cells
Set rng = cl.Range
rng.MoveEnd Word.WdUnits.wdCharacter, Count:=-1
For i = 1 To rng.words.Count
Set iRng = rng.words(i)
rng.Select
'insert your word manipulation code here
Debug.Print Selection.Text
Next i
Next cl
End If
End Sub
I need a VBA code for a simple copy and (paste) transpose row data and results looks like below
Row data
Final results
Kindly help me.
I hope you accept answer and upvote
Try this
Option Explicit
Sub Test()
Dim rng As Excel.Range
Set rng = Sheet1.Range("A1").CurrentRegion
Dim dicMaster As Object
Set dicMaster = VBA.CreateObject("Scripting.Dictionary")
Dim lRowLoop As Long
For lRowLoop = 1 To rng.Rows.Count
Dim vLeft As Variant
vLeft = rng.Cells(lRowLoop, 1)
Dim vRight As Variant
vRight = rng.Cells(lRowLoop, 2)
Dim dicSub As Object
If Not dicMaster.exists(vLeft) Then
Set dicSub = VBA.CreateObject("Scripting.Dictionary")
dicMaster.Add vLeft, dicSub
End If
Set dicSub = dicMaster.Item(vLeft)
dicSub.Add dicSub.Count, vRight
Next
'* find the widest
Dim lWidest As Long
lWidest = 0
Dim vKeyLoop As Variant
For Each vKeyLoop In dicMaster.Keys
Dim lCount As Long
lCount = dicMaster(vKeyLoop).Count
If lWidest < lCount Then lWidest = lCount
Next
'* so now dimension results
ReDim vResults(1 To dicMaster.Count, 1 To lWidest + 1) As Variant
Dim lRowIndex As Long
For Each vKeyLoop In dicMaster.Keys
lRowIndex = lRowIndex + 1
vResults(lRowIndex, 1) = vKeyLoop
Set dicSub = dicMaster.Item(vKeyLoop)
Dim lColIndex As Long
lColIndex = 2
Dim vItemLoop As Variant
For Each vItemLoop In dicSub.Items
vResults(lRowIndex, lColIndex) = vItemLoop
lColIndex = lColIndex + 1
Next vItemLoop
Next
Sheet2.Cells(1, 1).Resize(dicMaster.Count, lWidest + 1) = vResults
End Sub
I have an issue which I use a lot of manual time on currently.
I have following simple data:
And I wish to convert all the accounts downwards with the name next to the accounts in another column. Currently I do this by using the 'text to columns' function and then manually copy the names down.. HARD work.. :)
This is an example of my wish scenario..
Hope you are able to help..
Thanks a lot
Kristoffer
The following short macro will take data from Sheet1 and output records in Sheet2:
Sub DataReorganizer()
Dim i As Long, j As Long, N As Long
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 2 To N
v1 = s1.Cells(i, 1)
ary = Split(s1.Cells(i, 2), ";")
For Each a In ary
s2.Cells(j, 1).Value = v1
s2.Cells(j, 2).Value = a
j = j + 1
Next a
Next i
End Sub
Input:
and output:
Try this
Option Explicit
Sub Test()
Dim rng As Excel.Range
Set rng = ThisWorkbook.Worksheets.Item(1).Cells(1, 1).CurrentRegion
Set rng = rng.Offset(1)
Set rng = rng.Resize(rng.Rows.Count - 1)
Dim vPaste
Dim lTotalRows As Long
Dim lPass As Long
For lPass = 0 To 1
Dim rowLoop As Excel.Range
For Each rowLoop In rng.Rows
Dim sName As String
sName = rowLoop.Cells(1, 1)
Dim sAccounts As String
sAccounts = rowLoop.Cells(1, 2)
Dim vSplitAccounts As Variant
vSplitAccounts = VBA.Split(sAccounts, ";")
If lPass = 0 Then
lTotalRows = lTotalRows + UBound(vSplitAccounts) + 1
Else
Dim vLoop As Variant
For Each vLoop In vSplitAccounts
lTotalRows = lTotalRows + 1
vPaste(lTotalRows, 1) = sName
vPaste(lTotalRows, 2) = vLoop
Next vLoop
End If
Next
If lPass = 0 Then
ReDim vPaste(1 To lTotalRows, 1 To 2)
lTotalRows = 0
End If
Next
ThisWorkbook.Worksheets.Item(2).Cells(1, 1).Value = "Name"
ThisWorkbook.Worksheets.Item(2).Cells(1, 2).Value = "Account"
Dim rngPaste As Excel.Range
Set rngPaste = ThisWorkbook.Worksheets.Item(2).Cells(2, 1).Resize(lTotalRows, 2)
rngPaste.Value2 = vPaste
End Sub
i have an excel sheet like so:
HEADING <--A1 HEADING <-- this is B1
dhg kfdsl
56 fdjgnm
hgf fdkj
tr
465 gdfkj
gdf53
ry 4353
654 djk
354 <-- a12 blah <-- this is B12
I'm trying to put the range of cells in column A into a variant and remove any data from that variant if the cell in column B (for the same row in column A) is blank. Then i want to copy that variant to a new column (ie col c)
so my expected result is:
HEADING <--C1
dhg
56
hgf
465
ry
654
354 <-- C8
this is the code i have so far:
Dim varData As Variant
Dim p As Long
varData = originsheet.Range("B2:B12")
For p = LBound(varData, 1) To UBound(varData, 1)
If IsEmpty(varData(p, 1)) Then
remove somehow
End If
Next p
Dim bRange As range
Set bRange = originsheet.range("B2:B12")
Dim aCell, bCell, cCell As range
Set cCell = originsheet.Cells(2, 3) 'C2
For Each bCell In bRange
If bCell.Text <> "" Then
Set aCell = originsheet.Cells(bCell.Row, 1)
cCell.Value2 = aCell.Value2
Set cCell = originsheet.Cells(cCell.Row + 1, 3)
End If
Next bCell
Personally, I think your making this simple job harder, but here's how to do it the way you wanted:
Public Sub Test()
Dim Arange As Variant, Brange As Variant, Crange() As Variant
Dim i As Integer, j As Integer
Arange = Range("A2:A12")
Acount = Application.WorksheetFunction.CountA(Range("B2:B12"))
Brange = Range("B2:B12")
j = 1
ReDim Crange(1 To Acount, 1 To 1)
For i = 1 To UBound(Arange)
If Brange(i, 1) <> "" Then
Crange(j, 1) = Arange(i, 1)
j = j + 1
End If
Next i
Range("C2:C" & j) = Crange
End Sub
Try:
With ActiveSheet.UsedRange
.Cells(2, "C").Resize(.Rows.Count).Value = Cells(2, "A").Resize(.Rows.Count).Value
.Cells(2, "B").Resize(.Rows.Count).SpecialCells(xlCellTypeBlanks).Offset(, 1).Delete shift:=xlUp
End With
EDIT:
This is better:
With Range("A2", Cells(Rows.Count, "A").End(xlUp))
Cells(2, "C").Resize(.Rows.Count).Value = .Value
.Offset(, 1).SpecialCells(xlCellTypeBlanks).Offset(, 1).Delete shift:=xlUp
End With
You could also do it with advanced filter and no VBA.
Sub Main()
Dim rValues As Range
Dim vaIn As Variant
Dim vaTest As Variant
Dim aOut() As Variant
Dim i As Long
Dim lCnt As Long
Set rValues = Sheet1.Range("A2:A12")
vaIn = rValues.Value
vaTest = rValues.Offset(, 1).Value
ReDim aOut(1 To Application.WorksheetFunction.CountA(rValues.Offset(, 1)), 1 To 1)
For i = LBound(vaIn, 1) To UBound(vaIn, 1)
If Len(vaTest(i, 1)) <> 0 Then
lCnt = lCnt + 1
aOut(lCnt, 1) = vaIn(i, 1)
End If
Next i
Sheet1.Range("C2").Resize(UBound(aOut, 1)).Value = aOut
End Sub