The following script seems like it should work, but I'm getting an "Object defined" error on the lines marked below. I can't find what's causing this at all...
Sub MailMerge()
Sheets.Add.Name = "MailMerge"
Dim MailMerge As Worksheet
Set MailMerge = Sheets("MailMerge")
Dim Rng As Range
Dim i, index, lastrow As Long
Dim Abstracts As Worksheet
Set Abstracts = Sheets("Abstracts")
lastrow = Abstracts.Cells(Rows.Count, 1).End(xlUp).row
For i = 1 To lastrow
Set Rng = Abstracts.Range("O" & i)
If WorksheetFunction.CountA(Rng) >= 1 Then
Abstracts.Range("A" & i).Resize(0, 14).Copy _
Destination:=MailMerge.Range("A" & i).Resize(0, 14)
'this is where the error is occuring
End If
Next
End Sub
Any suggestions?
Resize is not like OFFSET. It will set the size of the range to the size dictated. So you are setting the range size to 0 rows. It should be 1:
Sub MailMerge()
Sheets.Add.Name = "MailMerge"
Dim MailMerge As Worksheet
Set MailMerge = Sheets("MailMerge")
Dim Rng As Range
Dim i, index, lastrow As Long
Dim Abstracts As Worksheet
Set Abstracts = Sheets("Abstracts")
lastrow = Abstracts.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastrow
Set Rng = Abstracts.Range("O" & i)
If WorksheetFunction.CountA(Rng) >= 1 Then
Abstracts.Range("A" & i).Resize(1, 14).Copy _
Destination:=MailMerge.Range("A" & i).Resize(1, 14)
'this is where the error is occuring
End If
Next
End Sub
Related
I am trying to write a macro that will look in column A on sheet1 and see if it is missing any values from column A on sheet2 or column A on sheet3. If it is missing have the value added to the bottom of the column A on sheet1. The same value may exist on sheet2 and sheet3 but it only needs to be represented once on sheet1.
I'm working with the code below.
Sub newRow()
Dim rngSh1 As Range, rngSh2 As Range, rngSh3 As Range, mySelSh2 As Range, mySelSh3 As Range
Dim lastRowSh1 As Long, lastRowSh2 As Long, lastRowSh3 As Long
Dim wb As Worksheet
Dim cell As Range
Set wb = ThisWorkbook
With wb
lastRowSh1 = Worksheets("Sheet1").Range("A" & .Rows.Count).End(xlUp).Row
lastRowSh2 = Worksheets("Sheet2").Range("A" & .Rows.Count).End(xlUp).Row
lastRowSh3 = Worksheets("Sheet3").Range("A" & .Rows.Count).End(xlUp).Row
Set rngSh1 = Worksheets("Sheet1").Range("A1:A" & lastRowSh1)
Set rngSh2 = Worksheets("Sheet2").Range("A1:A" & lastRowSh2)
Set rngSh3 = Worksheets("Sheet3").Range("A1:A" & lastRowSh3)
End With
For Each cell In rngSh2.Cells
If IsError(Application.Match(cell.Value, rngSh1, 0)) Then
If mySelSh2 Is Nothing Then
Set mySelSh2 = cell
Else
Set mySelSh2 = Union(mySelSh2, cell)
End If
End If
Next cell
If Not mySelSh2 Is Nothing Then mySelSh2.Copy Destination:=Worksheets("Sheet1").Range("A" & lastRowSh1 + 1)
For Each cell In rngSh3.Cells
If IsError(Application.Match(cell.Value, rngSh1, 0)) Then
If mySelSh3 Is Nothing Then
Set mySelSh3 = cell
Else
Set mySelSh3 = Union(mySelSh3, cell)
End If
End If
Next cell
If Not mySelSh3 Is Nothing Then mySelSh3.Copy Destination:=Worksheets("Sheet1").Range("A" & lastRowSh1 + 1)
End Sub
I've made every adjustment I can think of but with every change I make I get a different error.
Any help would be greatly appreciated. Thanks!
Save yourself a little bit of time using a Scripting.Dictionary:
Option Explicit
Sub test()
Dim dict As New Scripting.dictionary, sheetNum As Long
For sheetNum = 2 To Sheets.Count
With Sheets(sheetNum)
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim rowNum As Long
For rowNum = 1 To lastRow
Dim dictVal As Long: dictVal = .Cells(rowNum, 1).Value
If Not dict.Exists(dictVal) Then dict.Add dictVal, 0
Next rowNum
End With
Next sheetNum
With Sheets(1)
Dim checkableRangeLastRow As Long: checkableRangeLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim checkableRange As Range: Set checkableRange = .Range(.Cells(1, 1), .Cells(checkableRangeLastRow, 1))
Dim dictKey As Variant
For Each dictKey In dict.Keys
If IsError(Application.Match(dictKey, checkableRange, 0)) = True Then
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(lastRow + 1, 1).Value = dictKey
End If
Next dictKey
End With
End Sub
You add all values in your not-master-sheet into dict then loop through that list; if it's not found in your master-sheet, then you add then to the end of the list.
A significant note is that the Type of value used as the dictVal may cause the IsError() statement to always be True if it is not the same Type as the data being assessed in the checkableRange.
I have created below code which works like IF Col"B" any cell <> "" And Col"L" any cell = "Leop" then add row below to the active cell.
I mean I'm trying to achieve is to insert single row after certain row which contain in column B any value, and if column L in same row contains value = "Leop". Then add the row after that certain row.
But an error is appear. Compile Error: Invalid use of property on xlDown
Your help will be appreciated to fix it.
From this:
to this:
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long
Dim rng As Range
Dim rng2 As Range
Dim i As Long
Dim p As Long
Dim dat As Variant
Dim datt As Variant
Dim IRow As Long
Set ws = Thisworkbooks.Sheets("Sheet2")
With ws
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B2:B" & LRow)
Set rng2 = .Range("L2:L" & LRow)
dat = rng
datt = rng2
IRow = Selection.Row
For i = LBound(dat, 1) To UBound(dat, 1)
For p = LBound(datt, 1) To UBound(datt, 1)
If dat(i, 1) <> "" And datt(p, 1) = "Leop" Then
Rows(IRow + 1).Select
Selection.Insert Shift: xlDown
End If
End Sub
It will be like in formula:
IF(AND(B2<>"",L2="Leop"),"InsertRowBelow to Row 2 If condition is met","")
and will drag it down to the lastRow.
Thisworkbooks.Sheets("Sheet2") should be Thisworkbook.Sheets("Sheet2") and missing = in Selection.Insert Shift:= xlDown
Inserting or deleting rows will change the last row number so start at the bottom and work upwards.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet, LRow As Long, r As Long
Dim n As Long
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
LRow = .Range("B" & .Rows.Count).End(xlUp).Row
For r = LRow To 2 Step -1
If .Cells(r, "B") <> "" And .Cells(r, "L") = "Leop" Then
.Rows(r + 1).Insert shift:=xlDown
n = n + 1
End If
Next
End With
MsgBox n & " rows inserted", vbInformation
End Sub
Try this with autofilter, you dont have to loop through each row. So it will work faster for larger data.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long, cl As Range
Set ws = ThisWorkbook.Sheets("Sheet2")
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("L1:L" & LRow).AutoFilter 1, "Leop"
For Each cl In ws.Range("_FilterDatabase").SpecialCells(12).Cells
If ws.Range("B" & cl.Row) <> "" Then
cl.Offset(1).EntireRow.Insert Shift:=xlDown
End If
Next
ws.AutoFilterMode = False
End Sub
Sub MS()
Data = Sheets("Tabelle1").Select
Rows("1:1").Select
Rows("11409:11409").Select
Dim bilder As Long
Dim n As Long
Dim d As Long
Dim t As Long
bilder = 64
n = 1
d = 0
t = 0
'Dim i As Long
'For i = 1 To lastrow
Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row).Select
Range("b1:b" & Cells(Rows.Count, 1).End(xlUp).Row).Select
'Range("a1").Select
'Range("b1").Select
Range("a1,b1").Select
Do While ActiveCell.Value <> ""
Radius = Sqr(Range("A1").Value * Range("A1").Value + Range("B1").Value * Range("B1").Value)
ActiveCell.Offset(1, 1).Select
Loop
End Sub
I'm not sure why you'd want to do it this way (given that it can be done with a simple formula in-cell), but looking at the remnants of code in your question we can see what you're trying to achieve. Here's how I'd do it:
Sub MS()
Dim sht As Worksheet, StartRow As Long, LastRow As Long, OutputColumn As Long
Dim SideA As Double, SideB As Double, SideC As Double
With Worksheets("Tabelle1")
'Set StartRow to the first row of your data ignoring headers
StartRow = 2
'Locate LastRow as last occupied cell in column A
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Set OutputColumn to 3
OutputColumn = 3
'Start loop
For r = StartRow To LastRow
SideA = .Cells(r, 1).Value
SideB = .Cells(r, 2).Value
SideC = Sqr(SideA * SideA + SideB * SideB)
.Cells(r, OutputColumn).Value = SideC
Next
End With
End Sub
Output:
You do not need to select the range to work with it. You may want to see How to avoid using Select in Excel VBA
In your code you are not writing the output to any cell. Here are two ways that will help you achieve what you want.
NON VBA - WAY 1
Put the formula =SQRT(A1*A1+B1*B1) or =SQRT(A1^2+B1^2) in C1 and drag it down
VBA - WAY 2 (Without Looping)
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Set ws = Sheets("Tabelle1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C1:C" & lRow)
.Formula = "=SQRT(A1*A1+B1*B1)"
.Value = .Value
End With
End With
End Sub
VBA - WAY 3 (Without Looping) Slightly complicated way of doing this. Explanation can be seen HERE
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Set ws = Sheets("Tabelle1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C1:C" & lRow)
.Value = Evaluate("index(SQRT((A1:A" & lRow & _
")^2+(B1:B" & lRow & _
")^2),)")
End With
End With
End Sub
I have a question around Advanced Filters. I'm trying to figure out how to have a MsgBox Error message when the filter doesn't find a match.
I've put a comment within the first Sub (FilterData) where I thought the error message should go
Here's the code:
Public Sub FilterData()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim CriteriaRange As Range
Set CriteriaRange = ws.Range("J2", "L3")
Dim DataRange As Range
Set DataRange = ws.Range("A5", "I" & LastRow)
'This is where I thought I needed the OnError, but it shows the error message on every execution regardless of whether a match is found or not
On Error GoTo NoQuickFound
DataRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CriteriaRange, Unique:=False
NoQuickFound:
MsgBox "No match"
End Sub
Public Sub ShowAll()
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub
Public Sub GetNextResult()
FilterData
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim DataRange As Range
Set DataRange = ws.Range("A5", "I" & 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
Call ShowAll
TextboxName = "Box1"
ActiveSheet.Shapes(TextboxName).DrawingObject.Text = Cell.Offset(0, 2)
TextboxName2 = "Box2"
ActiveSheet.Shapes(TextboxName2).DrawingObject.Text = Cell.Offset(0, 3)
Call quick_artwork
End If
Next Cell
It is made up of 3 subs:
FilterData = Actually does the filtering of the results, this is where I expect I need to put the error message if it doesn't find a match
ShowAll = This resets the filtered results so it shows everything
GetNextResult = My spreadsheet doesn't actually show the filtered results, it replaces 2 text boxes with the values from the filter result and changes on every execution
Any ideas? Thanks!
Simple condition like this will work:
If Not DataRange.Columns(1).Rows.SpecialCells(xlCellTypeVisible).Count > 1 Then
MsgBox "No Results"
End If
Code:
Public Sub FilterData()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
Dim CriteriaRange As Range
Set CriteriaRange = ws.Range("J2", "L3")
Dim DataRange As Range
Set DataRange = ws.Range("A5", "I" & LastRow)
DataRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CriteriaRange, Unique:=False
If Not DataRange.Columns(1).Rows.SpecialCells(xlCellTypeVisible).Count > 1 Then
MsgBox "No Results"
End If
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