I feel like this is something stupidly simple, but I've been Googling and experimenting for a while and seem to be coming up empty handed guess is I'm searching the wrong term/word. Anyway, let me explain.
for Example :
this code: Run -Time error '13' Type mismatch
Dim ws, sh As Worksheet
Set ws = Worksheets("Sheet1")
Set sh = Worksheets("Sheet2")
Dim Ctr1, Ctr2, Result As Range
Set Ctr1 = ws.Range("A2:A100")
Set Ctr2 = ws.Range("B2:B100")
Set Result = ws.Range("C2:C100")
With sh
.Cells(2, 7).Value = WorksheetFunction.XLookup( _
.Cells(2, 5) & .Cells(2, 6), Ctr1 & Ctr2, Result, 0)
End With
End Sub
Create the XLOOKUP parameters from the range addresses.
Sub Macro1()
Dim ws As Worksheet, sh As Worksheet
Set ws = Worksheets("Sheet1")
Dim Ctr1, Ctr2, Result As Range
Set Ctr1 = ws.Range("A2:A100")
Set Ctr2 = ws.Range("B2:B100")
Set Result = ws.Range("C2:C100")
' XLOOKUP parameters
Dim p(3) As String, i As Long, w As String
w = "'" & ws.Name & "'!"
p(1) = w & Ctr1.Address(0, 0) & "&" & _
w & Ctr2.Address(0, 0)
p(2) = w & Result.Address(0, 0)
p(3) = 0
Set sh = Worksheets("Sheet2")
With sh
For i = 2 To 2
p(0) = .Cells(i, 5).Address(0, 0) & "&" & .Cells(i, 6).Address(0, 0)
.Cells(i, 7).Formula = "=XLOOKUP(" & Join(p, ",") & ")"
Next
End With
End Sub
Related
I'am writing simple code like nextCell.Value = dateJour.Value, were dateJour is a date located in a cell in the workbook.
When I loop (about 100 times) it takes forever because each nextCell.Value = dateJour.Value statement in the AddData procedure takes 0.2 seconds.
Same for .Range(nextCell.Offset(0, 1), nextCell.Offset(0, 8)).Value = wsSaisie.Range("A" & rowNumber, "H" & rowNumber).Value
The AddData procedure is called by fillData procedure and this is where the loop occurs.
It checks if the filled data by the user already exists in the data sheet called "Données". If not it adds data to the sheet (by calling AddData), if yes it modifies the data (by calling ChangeData). It goes/checks line by line because sometimes data has to be added or modified.
Thanks a lot for your help to improve my code !
Public Sub FillData()
Dim wsSaisie As Worksheet
Set wsSaisie = ThisWorkbook.Worksheets("Saisie")
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("Données")
Dim lastRow As Long, lastColumn As Long
lastRow = wsSaisie.Range("A:H").Find("*" _
, LookAt:=xlPart _
, LookIn:=xlFormulas _
, SearchOrder:=xlByRows _
, SearchDirection:=xlPrevious).Row
Dim rowKey As String
Dim foundRowNumber As Long
Dim cell As Range
For Each cell In wsSaisie.Range(wsSaisie.Range("I5"), wsSaisie.Range("I" & lastRow))
rowKey = cell.Value
foundRowNumber = DataAlreadyExists(rowKey)
If foundRowNumber = -1 Then
Call AddData(cell.Row)
Else
Call ChangeData(foundRowNumber, cell.Row)
End If
Next cell
End Sub
Public Sub AddData(rowNumber As Long)
Dim wsSaisie As Worksheet
Set wsSaisie = ThisWorkbook.Worksheets("Saisie")
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("Données")
Dim dateJour As Range
Set dateJour = wsSaisie.Range("B1")
Dim nextCell As Range
Set nextCell = wsData.Range("A1048576").End(xlUp).Offset(1, 0)
'StartTime = Timer
nextCell.Value = dateJour.Value
'Debug.Print Round(Timer - StartTime, 2)
wsData.Range(nextCell.Offset(0, 1), nextCell.Offset(0, 8)).Value = wsSaisie.Range("A" & rowNumber, "H" & rowNumber).Value
End Sub
Public Sub ChangeData(rowTo As Long, rowFrom As Long)
Dim wsSaisie As Worksheet
Set wsSaisie = ThisWorkbook.Worksheets("Saisie")
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("Données")
wsData.Range("G" & rowTo & ":" & "I" & rowTo).Value = wsSaisie.Range("F" & rowFrom & ":" & "H" & rowFrom).Value
End Sub
Public Function DataAlreadyExists(key As String) As Long
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("Données")
If Not IsError(Application.Match(key, wsData.Range("K:K"), 0)) Then
DataAlreadyExists = Application.Match(key, wsData.Range("K:K"), 0)
Else
DataAlreadyExists = -1
End If
End Function
Use Value2 instead of Value (ref.)
i.e. in AddData()
nextCell.Value2 = dateJour.Value2
and
nextCell.Offset(0, 1).Resize(1, 8).Value2 = wsSaisie.Cells(rowNumber, 1).Resize(1, 8).Value2
Also, in your DataAlreadyExists() function, you evaluate MATCH twice when data do exist, e.g. consider this
Public Function DataAlreadyExists(key As String) As Long
Dim wsData As Worksheet, resultat as Variant
Set wsData = ThisWorkbook.Worksheets("Données")
resultat = Application.Match(key, wsData.Range("K:K"), 0)
If Not IsError(resultat) Then
DataAlreadyExists = resultat
Else
DataAlreadyExists = -1
End If
End Function
I would appreciate if I can get help in creating this macro. I have two workbooks, and want to compare the specific column from 1st workbook, Ex: Column H with next work book, Ex: column A. After comparison highlight the matching cells in 1st workbook. I have tried below script for comparison, it is executing successfully, but not seeing any result.
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, w(), i As Long
Dim r As Range, myCol As String
Set ws1 = ThisWorkbook.Sheets(1)
Set ws2 = Workbooks("workbook.xlsx").Sheets(1)
With CreateObject("VBScript.RegExp")
.Pattern = "^([a-z]|[a-h][a-z]|[a-i][a-v])$"
.IgnoreCase = True
Do
myCol = InputBox("Enter Column")
Loop While Not .test(myCol)
End With
With CreateObject("Scripting.Dictionary")
.comparemode = vbTextCompare
For Each r In ws1.Range(myCol & "1", ws1.Range(myCol & Rows.Count).End(xlUp))
If Not IsEmpty(r) And Not .exists(r.Value) Then
ReDim w(0): w(0) = r.Row
.Add r.Value, w
Else
w = .Item(r.Value)
ReDim Preserve w(UBound(w) + 1)
w(UBound(w)) = r.Row
.Item(r.Value) = w
End If
Next
For Each r In ws2.Range("a1", ws2.Range("a" & Rows.Count).End(xlUp))
If .exists(r.Value) Then
For i = 0 To UBound(.Item(r.Value))
ws1.Range(myCol & .Item(r.Value)(i)).Offset(, 1).Resize(, 23).Value = _
r.Offset(, 1).Resize(, 23).Value
Next
End If
Next
End With
Set ws1 = Nothing: Set ws2 = Nothing
End Sub
Try
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, w(), i As Long, n As Integer
Dim r As Range, myCol As String, wbname As String, msg As String
Set ws1 = ThisWorkbook.Sheets(1)
Dim myworkbooks As Variant, mycolors As Variant
' workbooks to compare
myworkbooks = Array("Workbook1.xlsx", "Workbook2.xlsx", "Workbook3.xlsx")
mycolors = Array(vbYellow, vbGreen, vbBlue)
' select column
With CreateObject("VBScript.RegExp")
.Pattern = "^([a-z]|[a-h][a-z]|[a-i][a-v])$"
.IgnoreCase = True
Do
myCol = InputBox("Enter Column")
Loop While Not .test(myCol)
End With
' build dictionary
With CreateObject("Scripting.Dictionary")
.comparemode = vbTextCompare
For Each r In ws1.Range(myCol & "1", ws1.Range(myCol & Rows.Count).End(xlUp))
If IsEmpty(r) Then
' skip empty cells
Else
If Not .exists(r.Value) Then
ReDim w(0): w(0) = r.Row
.Add r.Value, w
Else
w = .Item(r.Value)
ReDim Preserve w(UBound(w) + 1)
w(UBound(w)) = r.Row
.Item(r.Value) = w
End If
End If
Next
' compare and highlight match
For n = 0 To UBound(myworkbooks)
Debug.Print "Opening " & myworkbooks(n)
msg = msg & vbCrLf & myworkbooks(n)
Set ws2 = Workbooks(myworkbooks(n)).Sheets(1)
For Each r In ws2.Range("a1", ws2.Range("a" & Rows.Count).End(xlUp))
If .exists(r.Value) Then
For i = 0 To UBound(.Item(r.Value))
ws1.Range(myCol & .Item(r.Value)(i)).Interior.color = mycolors(n)
Next
End If
Next r
Next n
End With
Set ws1 = Nothing: Set ws2 = Nothing
MsgBox "Completed scanning" & msg, vbInformation
End Sub
I try to compare two columns and get the non-matching results listed somewhere else.
So far I've come up with the following:
Sub match_columns()
Dim i, Lastrow1, Lastrow3 As Integer
Dim found As Range
With Worksheets("sht1")
Lastrow1 = .Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To Lastrow1
answer1 = .Range("A" & i).Value
Set found = Sheets("sht2").Columns("A:A").Find(what:=answer1)
If found Is Nothing Then
Set rngNM = .Range("A" & i.Row)
Else
Set rngNM = Union(rngNM, .Range("A" & i.Row))
End If
Next i
End With
If Not rngNM Is Nothing Then rngNM.Copy Worksheets("sht3").[A2]
Worksheets("sht3").[A1] = "title"
Lastrow3 = Sheets("sht3").Range("A" & Rows.Count).End(xlUp).Row
Sheets("sht3").Range("A2:A" & Lastrow3).Copy
End Sub
I currently get an "Runtime error 424; Object required" for the following:
Set rngNM = .Range("A" & i.Row)
Where is my code wrong?
Try this code
Sub Compare_Two_Columns()
Dim ws As Worksheet, sh As Worksheet, out As Worksheet, c As Range, i As Long, m As Long, k As Long
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set sh = ThisWorkbook.Worksheets("Sheet2")
Set out = ThisWorkbook.Worksheets("Sheet3")
m = ws.Range("A" & Rows.Count).End(xlUp).Row
ReDim a(1 To m)
For i = 1 To m
Set c = sh.Range("A:A").Find(What:=ws.Cells(i, 1).Value, LookAt:=xlWhole)
If c Is Nothing Then k = k + 1: a(k) = ws.Cells(i, 1).Value
Next I
If k > 0 Then
With out
.Range("A1").Value = "Title"
.Range("A2").Resize(k).Value = Application.Transpose(a)
End With
End If
Application.ScreenUpdating = True
MsgBox "Done...", 64
End Sub
I adapted code I found online.
It finds the string "car" in column A and returns the rows as an array
It assigns a variable to the length of the array (how many matches it found)
It assigns a variable to generate a random number between 0 and the length of the array
It then prints a random matching row's value into K3
Dim myArray() As Variant
Dim x As Long, y As Long
Dim msg As String
With ActiveSheet.Range("A1:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row)
Set c = .find("Car", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
ReDim Preserve myArray(y)
myArray(y) = c.Row
y = y + 1
Set c = .findNext(c)
If c Is Nothing Then
GoTo DoneFinding
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
For x = LBound(myArray) To UBound(myArray)
msg = msg & myArray(x) & " "
Next x
ArrayLen = UBound(myArray) - LBound(myArray)
random_index = WorksheetFunction.RandBetween(0, ArrayLen)
MsgBox myArray(random_index)
Dim test As String
test = "B" & myArray(random_index)
Range("K3").Value = Range(test)
Example
I'm struggling with adapting the find code to allow for multiple criteria. So in my example, it finds "Car". What if I want to find matches that had "Car" in column A and "Red" in column D?
I tried
With ActiveSheet.Range("A1:A" & "D1:D" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row & ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row)
Set c = .find("Car", "Red", LookIn:=xlValues)
I get type mismatch on the Set line.
In case it is confusing, it currently looks for a string e.g. "Car" but I will eventually link this to the variable which will be assigned to a data validation list. So if the user chooses "car" from a drop down list, this is what it will search for.
Maybe Advancde Filter is something that fit your needs:
Example Code
Option Explicit
Public Sub FilterData()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim CriteriaRange As Range
Set CriteriaRange = ws.Range("A1", "E2")
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
DataRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CriteriaRange, Unique:=False
End Sub
Public Sub ShowAll()
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub
Edit according comment:
You can use the advanced filter and then loop through the filter results:
Option Explicit
Public CurrentRow As Long
Public Sub FilterData()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim CriteriaRange As Range
Set CriteriaRange = ws.Range("A1", "E2")
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
DataRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CriteriaRange, Unique:=False
End Sub
Public Sub ShowAll()
On Error Resume Next
ActiveSheet.ShowAllData
CurrentRow = 1
On Error GoTo 0
End Sub
Public Sub GetNextResult()
FilterData
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
Dim FilteredData As Range
Set FilteredData = DataRange.Resize(ColumnSize:=1).SpecialCells(xlCellTypeVisible)
If CurrentRow + 1 > FilteredData.Cells.Count Then
CurrentRow = 1
End If
CurrentRow = CurrentRow + 1
Dim i As Long
Dim Cell As Variant
For Each Cell In FilteredData
i = i + 1
If i = CurrentRow Then
Cell.EntireRow.Select
'or
'MsgBox Cell.Value & vbCrLf & Cell.Offset(0, 1) & vbCrLf & Cell.Offset(0, 2) & vbCrLf & Cell.Offset(0, 3) & vbCrLf & Cell.Offset(0, 4)
End If
Next Cell
End Sub
I'm trying to dynamically add multiple series to a line chart. I don't know beforehand how many series there are so it needs to be dynamic. What I've come up with but doesn't work is the following:
The sheet ActiveSheet (or Sheets("Data")) has Rows from C14 until Cend containing the XValues and Columns from E14:Eend until R14:Rend where "end" marks the last row of data as determined by column C. The series names are stored in row 9. XValues are the same for all series.
My big problem is, that I can't find a way to dynamically add all the data columns as series to my chart together with the respective name. I'm not an expert in VBA so please be kind. I already read various sources and tried many scripts, none seem to work. The Object Catalogue was a bit of a help, however my problem persists.
Sub MakeChart()
Dim LastColumn As Long
Dim LastRow As Long
Dim i As Integer
Dim u As Integer
Dim NameRng As String
Dim CountsRng As Range
Dim xRng As Range
LastColumn = ActiveSheet.Cells(8, Columns.Count).End(xlToLeft).Column
ColumnCount = LastColumn - 4
LastRow = ActiveSheet.Range("C" & ActiveSheet.Rows.Count).End(xlUp).Row
' Debug.Print ("Last Column: " & LastColumn & " Count: " & ColumnCount & " LastRow: " & LastRow)
Charts.Add
With ActiveChart
.ChartType = xlLineMarkers
.HasTitle = True
.ChartTitle.Text = "Test"
End With
For i = 1 To ColumnCount
u = i + 4
NameRng = Sheets("Data").Range("R9:C" & u).Value
Set xRng = Sheets("Data").Range("R14:C3", "R" & LastRow & ":C3")
Set CountsRng = Sheets("Data").Range("R14:C" & u, "R" & LastRow & ":C" & u)
' Debug.Print ("CountsRng: R14:C" & u & ", R" & LastRow & ":C" & u & " NameRng: " & NameRng & " xRng: R14:C3 , R" & LastRow & ":C3")
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(i).XValues = xRng
ActiveChart.SeriesCollection(i).Values = CountsRng
ActiveChart.SeriesCollection(i).Name = NameRng
Next i
End Sub
thanks for the help. I solved the problem. It seems as I have somehow completely messed up the notation of the cell range. You cannot use
Set xRng = Sheets("Data").Range("R14:C3", "R" & LastRow & ":C3")
But rather have to use
Set xRng = .Range(.Cells(14, 3), .Cells(LastRow, 3))
Also, the use of Charts.Add didnt help very much as Excel tries to automatically find the correct ranges for all series and adds them resulting in a completely messed up chart. A better way was to use
Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=20, Width:=800, Top:=20, Height:=500)
As this will create a completely empty graph to which you can add your own series
Here is the complete and working code for anyone interested:
Sub MakeChart()
Dim LastRow As Long
Dim LastColumn As Long
Dim ColumnCount As Long
LastRow = ActiveSheet.Range("C" & ActiveSheet.Rows.Count).End(xlUp).Row
LastColumn = ActiveSheet.Cells(8, Columns.Count).End(xlToLeft).Column
ColumnCount = LastColumn - 4
Debug.Print ("Last Column: " & LastColumn & " Count: " & ColumnCount & " LastRow: " & LastRow)
Dim wsChart As Worksheet
Set wsChart = Sheets(1)
wsChart.Activate
Dim ChartObj As ChartObject
Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=20, Width:=800, Top:=20, Height:=500)
ChartObj.chart.ChartType = xlLineMarkers
Dim i As Integer
Dim u As Integer
Dim NameRng As String
Dim xRng As Range
Dim CountsRng As Range
For i = 1 To ColumnCount
u = i + 4
With Sheets("Data")
NameRng = .Cells(9, u).Value
Set CountsRng = .Range(.Cells(14, u), .Cells(LastRow, u))
Set xRng = .Range(.Cells(14, 3), .Cells(LastRow, 3))
Debug.Print "--" & i & "--" & u & "--"
Debug.Print "x Range: " & xRng.Address
Debug.Print "Name Range: " & .Cells(9, u).Address
Debug.Print "Value Range: " & CountsRng.Address
End With
'Set ChartSeries = ChartObj.chart.SeriesCollection.NewSeries
'With ActiveChart.SeriesCollection.NewSeries
With ChartObj.chart.SeriesCollection.NewSeries
.XValues = xRng
.Values = CountsRng
.Name = NameRng
End With
'Set xRng = Nothing
'Set CountsRng = Nothing
'NameRng = ""
Next i
'ChartObj.Activate
With ChartObj.chart
.SetElement (msoElementLegendBottom)
.Axes(xlValue).MajorUnit = 1
.Axes(xlValue).MinorUnit = 0.5
.Axes(xlValue).MinorTickMark = xlOutside
'.Axes(xlCategory).TickLabels.NumberFormat = "#,##000"
.Axes(xlCategory).TickLabels.NumberFormat = "#,##0"
'.Location Where:=xlLocationAsObject, Name:="Plot"
End With
End Sub
sample code
Sub InsertChart()
Dim first As Long, last As Long
first = 10
last = 20
Dim wsChart As Worksheet
Set wsChart = Sheets(1)
wsChart.Activate
wsChart.Shapes.AddChart.Select
Dim chart As chart
Set chart = ActiveChart
chart.ChartType = xlXYScatter
' adding series
chart.SeriesCollection.NewSeries
chart.SeriesCollection(1).Name = "series name"
chart.SeriesCollection(1).XValues = "=" & ActiveSheet.Name & "!$A$" & first & ":$A$" & last
chart.SeriesCollection(1).Values = "=" & ActiveSheet.Name & "!$B$" & first & ":$B$" & last
End Sub
you can iterate over range and keep adding more series