I have to compare the username from 2 workbooks in Excel using VBA. How does one do this?
For example :
In workbook 1 : column A contains 10 names
In workbook 2 : column A contains 10 names
I need to have the cell of column B in each workbook be colored Green or Red based on the match.
I "think" that you mean something like this, but I know I always need to be prudent.
The code below should work, but probably you will want to set the ranges more dynamically.
Option Explicit
Sub Compare_Names()
Dim oBook_1 As Excel.Workbook
Dim oBook_2 As Excel.Workbook
Dim oRange_1 As Range
Dim iRange_1_Rows As Integer
Dim oRange_2 As Range
Dim iRange_2_Rows As Integer
Dim vArray As Variant
Dim vArray_Found As Variant
Dim iCnt As Integer
Dim iCnt_B As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set oBook_1 = Workbooks.Open("U:/Names_1.xls")
Set oRange_1 = oBook_1.Sheets(1).Range("A1:A5") 'Can be dynamically set when needed
iRange_1_Rows = oRange_1.Rows.Count
ReDim vArray(1 To iRange_1_Rows, 1 To 1)
vArray = oRange_1
Set oRange_1 = Nothing
oBook_1.Close
Set oBook_1 = Nothing
Set oBook_2 = Workbooks.Open("U:/Names_2.xls")
Set oRange_2 = oBook_2.Sheets(1).Range("A1:A5")
iRange_2_Rows = oRange_2.Rows.Count
For iCnt = 1 To iRange_1_Rows
For iCnt_B = 1 To iRange_2_Rows
ReDim vArray_Found(1 To iRange_2_Rows, 1 To 1)
If Trim(vArray(iCnt, 1)) = Trim(oRange_2(iCnt_B)) Then
oRange_2(iCnt_B).Interior.Color = vbGreen
vArray(iCnt_B, 1) = True
End If
Next iCnt_B
Next iCnt
For iCnt = 1 To iRange_2_Rows
If vArray(iCnt, 1) <> True Then
oRange_2(iCnt).Interior.Color = vbRed
End If
Next iCnt
Set oRange_2 = Nothing
oBook_2.Save
oBook_2.Close
Set oBook_2 = Nothing
End Sub
If you want a non-case sensitive comparison you can use:
if UCase(Trim(vArray(iCnt, 1))) = UCase(Trim(oRange_2(iCnt_B))) Then
Related
I have a file with multiple tables and by using the below code I am trying to access the rows which have specific terms using an array.
I successfully select the whole rows but when I try to apply the Hidden behavior on the whole row then VBA through an error.
Getting error on below the line
Selection.Font.Hidden = True
Below is my whole code
Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object, aRng As Range
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
'********** change address to suit
FileStr = "C:\Users\krishna.haldunde\Downloads\DE\DE\International_DE.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("French", "Spanish")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = TblCell.Range
'If TblCell.RowIndex = WrdApp.ActiveDocument.Tables(Cnt).Rows.Count Then Exit For
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
aRng.Select
Selection.Font.Hidden = True
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where i am doing issue so, i can rectify it.
I think it's more effective to reduce the row height to an exact minimum value.
Something like this works for me.
Sub Test()
SearchArr = Array("sdg", "sdh", "dsf")
'loop tables
For Cnt = 1 To ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each tblCell In ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = tblCell.Range
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).HeightRule = wdRowHeightExactly
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).Height = 1
End If
Next tblCell
Next Arrcnt
Next Cnt
End Sub
I have been working on this code that takes misspelled words from a document and then turns them into a table with all the misspelled words on one column. Then the words are spellchecked and the corrections appear on the other column. My code does everything that I want it to, however only the first word appears on each cell. What am I doing wrong?
Sub SuperSpellCheck()
Dim doc1 As Document
Dim doc2 As Document
Dim tb As Table
Set doc1 = ActiveDocument
Set doc2 = Documents.Add
doc1.Activate
Dim badw As Range
Dim rng As Range
Dim sugg As SpellingSuggestions
Dim sug As Variant
err = doc1.SpellingErrors.Count
For Each badw In doc1.SpellingErrors
doc2.Range.InsertAfter badw & vbCr
Next
doc2.Activate
Set tb = ActiveDocument.Content.ConvertToTable(Separator:=wdSeparateByParagraphs, NumColumns:=1,
NumRows:=ActiveDocument.SpellingErrors.Count, AutoFitBehavior:=wdAutoFitFixed)
With tb
.Style = "Table Grid"
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.Columns.Add
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
End With
err2 = ActiveDocument.SpellingErrors.Count
i = 1
Set sugg = doc2.Range.GetSpellingSuggestions
For Each rng In doc2.Range.SpellingErrors
With rng
If sugg.Count > 0 Then
Set sug = .GetSpellingSuggestions
tb.Cell(i, 2).Range.InsertAfter sug(1)
End If
End With
Next
End Sub
Not connected to your problem but you need to change these lines
Err = doc1.SpellingErrors.Count
err2 = ActiveDocument.SpellingErrors.Count
To:
Dim errors1 as Long, dim errors2 as Long
errors1 = doc1.SpellingErrors.Count
errors2 = doc2.SpellingErrors.Count
Err is an object in VBA that holds the errors generated by your code. You also haven't declared those variables. Add Option Explicit at the very top of your code module and you will be alerted to any undeclared variables. To turn this on automatically in future go to Tools | Options | Editor and ensure that Require Variable Declaration is checked.
I would change
Dim sugg As SpellingSuggestions
Dim sug As Variant
to
Dim docSugg As SpellingSuggestions
Dim rngSugg As SpellingSuggestions
Dim sug As SpellingSuggestion
This will make it clearer what each of these represents.
SpellingSuggestions is a collection of SpellingSuggestion objects so you can use sug to loop through the collection.
i = 1
Set sugg = doc2.Range.GetSpellingSuggestions
For Each rng In doc2.Range.SpellingErrors
With rng
If sugg.Count > 0 Then
Set sug = .GetSpellingSuggestions
tb.Cell(i, 2).Range.InsertAfter sug(1)
End If
End With
Next
In this block of code you start off by setting the undeclared variable i to a value of 1, but you don't then increase that value. This will result in all your spelling suggestions being inserted in the same cell. Also, when you insert the spelling suggestion you only ever insert the first one as you don't have a means of looping through them. So I would rewrite this as:
i = 1
Set docSugg = doc2.Range.GetSpellingSuggestions
For Each rng In doc2.Range.SpellingErrors
With rng
If docSugg.Count > 0 Then
Set rngSugg = .GetSpellingSuggestions
For Each sug In rngSugg
tb.Cell(i, 2).Range.InsertAfter sug
Next
End If
End With
i = i + 1
Next
EDIT: If you only want the first suggested spelling then use:
i = 1
Set docSugg = doc2.Range.GetSpellingSuggestions
For Each rng In doc2.Range.SpellingErrors
With rng
If docSugg.Count > 0 Then
Set rngSugg = .GetSpellingSuggestions
tb.Cell(i, 2).Range.InsertAfter rngSugg(1)
End If
End With
i = i + 1
Next
I'm not so good with VBA, thus I'm suspecting an issue with declaring and later on using the dictionary.
I've taken a different approach. Created two functions to creat the dicts.
The for loop first is checking if the Control in userform is textbox, than is getting column number (dict_col) and checks if needs to be formatted as date (dict_for).
However each time the second dict seems to be empty... When I check content of each dict separately (before the loop), it shows correct values.
Public Function import_columns(rng As Variant) As Dictionary
Dim dict As New Dictionary
Dim i As Long
Dim count_rows As Long
Dim dict_k As String, dict_i As String
count_rows = rng.Rows.Count
For i = 1 To count_rows
dict_k = rng(i, 2)
dict_i = rng(i, 1)
dict.Add dict_k, dict_i
Next i
Set import_columns = dict
End Function
Public Function import_format(rng As Variant) As Dictionary
Dim dict_f As New Dictionary
Dim i As Long
Dim count_rows As Long
count_rows = rng.Rows.Count
For i = 1 To count_rows
dict_f(rng(i, 1)) = 0
Next i
Set import_format = dict_f
End Function
Private Sub UserForm_Initialize()
'On Error GoTo ErrorHandle
Dim wb As Workbook
Dim rng_col As Range
Dim rng_format As Range
Dim dc_value As Integer
Dim ctrl As Control
Dim ctrlType As String
Dim ctrl_name As String
Dim key As Variant
Dim dict_col As Dictionary
Dim dict_for As Dictionary
Set rng_col = Application.Union(Range("columns_mark").Columns(3), Range("columns_mark").Columns(2))
Set rng_format = Arkusz25.Range("H1").CurrentRegion
Set dict_col = import_columns(rng_col)
Set dict_for = import_format(rng_format)
'Me.Results.Enabled = False
ListBox1.RowSource = "lista"
txt_results = ListBox1.ListCount
For Each key In dict_col.Keys
'If dict_col.Exists(key) Then
Debug.Print key
Debug.Print dict_col(key)
'End If
Next key
ctrlType = "TextBox"
For Each ctrl In Results.Controls
ctrl_name = ctrl.Name
If TypeName(ctrl) = ctrlType Then
dc_value = dict_col(ctrl_name)
If dict_for.Exists(ctrl_name) Then
ctrl = Format(Val(ListBox1.List(0, dc_value - 1)), "dd.mm.yyyy")
Else
ctrl = ListBox1.List(0, dc_value - 1)
End If
ctrl.Enabled = False
End If
Next ctrl
I need to delete specific rows in a table with a order number. When I put this code in Excel it delete the entire table. What I want is to delete only specific rows. The tbxOrder is a text box. I want that when the text box equals x command number the code will select all the rows with the same number in the "Pagination" table (column 20) and then delete them. Thank you :)
Public Sub DeleteOrderRows()
Dim strNoOrder As String
Dim strNoFunction As String
Dim noCommande As Integer
Dim tblPagination As ListObject
Set tblPagination = Worksheets("Pagination").ListObjects.Item("tblPagination")
For Each srcrow In tblPagination.ListRows
strNoOrder = srcrow.Range.Cells(1, 20)
noOrder = tbxOrder.Value
If strNoOrder = noOrder Then
EntireRow.Delete
End If
Next
End Sub
Try it without the ListRows; use DataBodyRange instead. Work from the bottom to the top or you risk skipping rows when you delete.
Option Explicit
Public Sub DeleteOrderRows()
Dim strNoOrder As String
Dim strNoFunction As String, noOrder As String
Dim noCommande As Integer
Dim i As Long, tbxOrder As Range
Dim tblPagination As ListObject
Set tblPagination = Worksheets("Pagination").ListObjects.Item("tblPagination")
'here I had to set tbvOrder and assign noOrder
Set tbxOrder = Worksheets("Pagination").Cells(1, "A")
noOrder = tbxOrder.Value
With tblPagination.DataBodyRange.Columns(20).Cells
For i = .Count To 1 Step -1
Debug.Print .Cells(i).Address(0, 0)
strNoOrder = .Cells(i).Value2
If strNoOrder = noOrder Then
.Cells(i).EntireRow.Delete
End If
Next i
End With
End Sub
An other option :
Public Sub DeleteOrderRows()
Dim rngToDelete As Range
Set rngToDelete = Nothing
Dim tblPagination As ListObject
Set tblPagination = Worksheets("Pagination").ListObjects.Item("tblPagination")
Dim strNopage As String
Dim strNoOrder As String
For Each currentRow In tblPagination.ListRows
strNoOrder = currentRow.Range.Cells(1, 5).Value
strNopage = tbxPage.Value
If strNoCommande = strNopage Then
If rngToDelete Is Nothing Then
Set rngToDelete = currentRow.Range
Else
Set rngToDelete = Union(rngToDelete, currentRow.Range)
End If
End If
Next
If Not rngToDelete Is Nothing Then
rngToDelete.Delete Shift:=xlUp
End If
End Sub
I am trying to create a VB macro in Visio that can read the data and properties of the shape. So say I have a Rectangle Shpae in Visio with Cells Name, Description, Type, Size.... and so on.
When I try to read the cells and their values I am only getting the first cell and its value.
Here is my code . I would appreciate some help here.
Sub Testing()
Dim excelObj As Object
Dim excelFile As String
Dim sheetName As String
' Dim excelBook As Excel.Workbook
' Set excelFile = "C:\Users\hbhasin\Documents\test.xls"
'Set sheetName = "New Sheet name"
Set excelObj = CreateObject("Excel.Application")
excelObj.Workbooks.Add
Dim pagObj As Visio.Page
Dim shpsObj As Visio.shapes
Dim shapes As Visio.shapes
Dim shpObj As Visio.Shape
Dim CellObj As Visio.Cell
Dim Storage() As String
Dim iShapeCount As Integer
Dim i As Integer
Dim j As Integer
Set pagObj = ActivePage
Set shpsObj = pagObj.shapes
iShapeCount = shpsObj.Count
Debug.Print iShapeCount
ReDim Storage(8, iShapeCount - 1)
For i = 1 To iShapeCount - 1
Set shpObj = shpsObj(i)
Storage(1, i - 1) = shpObj.Name
If shpObj.CellExists("Prop.Name", visExistsLocally) Then
Set CellObj = shpObj.CellsU("Prop.Name")
Storage(2, i - 1) = CellObj.ResultStr("")
End If
If shpObj.CellExists("Prop.Description", visExistsLocally) Then
Debug.Print "Test the IF statement"
Set CellObj = shpObj.CellsU("Prop.Description")
Storage(3, i - 1) = CellObj.ResultStr("")
End If
Next
For i = 0 To iShapeCount - 1
Debug.Print "Name- " & Storage(0, i)
Debug.Print "Description-" & Storage(1, i)
Next
End Sub
In fact, I have put a debug statement within the second if clause and that does not execute which tells me the compiler is not even seeing the second cell or any cell after.
If you're not getting the Description Shape Data it maybe that it's not local, but inherited from its master. Here's a slight modification of your code (with the Excel part removed as I don't think it's relevant here):
Sub Testing()
Dim shpsObj As Visio.shapes
Set shpsObj = ActivePage.shapes
Dim iShapeCount As Integer
iShapeCount = shpsObj.Count
'Assumes you want an array of shape data
Dim Storage() As String
ReDim Storage(iShapeCount - 1, 2)
'Visio shapes are 1 based so use full count
Dim i As Integer
Dim shpObj As Visio.Shape
For i = 1 To iShapeCount
Set shpObj = shpsObj(i)
Storage(i - 1, 0) = shpObj.Name 'Do you want NameU?
'Assumes you don't care whether the cell is local or inherited
If shpObj.CellExistsU("Prop.Name", visExistsAnywhere) Then
Storage(i - 1, 1) = shpObj.CellsU("Prop.Name").ResultStr("")
End If
If shpObj.CellExistsU("Prop.Description", visExistsAnywhere) Then
Storage(i - 1, 2) = shpObj.CellsU("Prop.Description").ResultStr("")
End If
Next
Dim j As Long
For j = LBound(Storage, 1) To UBound(Storage, 1)
Debug.Print "Shape Name- " & Storage(j, 0)
Debug.Print " Prop.Name- " & Storage(j, 1)
Debug.Print " Prop.Description- " & Storage(j, 2)
Next j
End Sub
If you're just running through all the shapes on the page, then you might want to look at For Each shp In shapes as an alternative. Check out this page for more details:
http://visualsignals.typepad.co.uk/vislog/2007/11/looping-through.html
Also, you might want to try look at the CreateSelection page method to narrow down your target shapes if you're dealing with a large number