I'm trying to write up a script which will do the following things in the following order:
Locate a range that is located between 2 cells containing specific strings (DateRng)
Search within this range for a cell (i) that has a value <=Value
Compare two other cells which are offset to "i"
Export a range of rows centered around "i" to different sheets pending the outcome of
the above condition.
I can get steps 2 & 4 to work (if step 2 searched the entire sheet instead of DateRng.
I can also get step 1 to work
However, when I try to put it all together I get an error msg: Method 'Range' of object'_Global' failed.
This makes no sense to me as DateRng is being found.
If someone could advise on this that would be great. I have just started learning VBA so i am wide open to suggestions/corrections for the rest of the script too.
Below I have pasted the offending script with the line the Debugger stops on marked
Sub ReportCells()
Dim LR As Long, i As Long
Dim j, k As Long
Dim StartDate, FinishDate As String
Dim Sh As Worksheet: Set Sh = Sheets("Full chart and primary cals")
Dim CellFound As Range
'Range Extraction Script
'Search location and values
LookupColumn = "B"
StartDate = "2013.01.02 20:00"
FinishDate = "2013.01.09 20:00"
'Find Lower Limit
For j = 1 To 30000
If Sh.Range(LookupColumn & j).Value = FinishDate Then FinishDateRow = j
Next j
'Find Upper Limit
For k = FinishDateRow To 1 Step -1
If Sh.Range(LookupColumn & k).Value = StartDate Then StartDateRow = k - 1
Next k
'Set Range once located
Dim DateRng As Range: Set DateRng = Sh.Range(LookupColumn & StartDateRow & ":" & LookupColumn & FinishDateRow)
MsgBox DateRng.Address
'Find Cell
**With Range("DateRng")**
For i = 1 To LR
Set CellFound = .Find(Sh.Range("M:M").Value <= 25)
If Not CellFound Is Nothing And .Range("CellFound").Offset(0, -4).Value < .Range("CellFound").Offset(-10, -4).Value Then .Offset(-3, 0).Resize(10, 1).EntireRow.Copy Destination:=Sheets("Sheet18").Range("A" & Rows.Count).End(xlUp).Offset(2)
If Not CellFound Is Nothing And .Range("CellFound").Offset(0, -4).Value > .Range("CellFound").Offset(-10, -4).Value Then .Offset(-3, 0).Resize(10, 1).EntireRow.Copy Destination:=Sheets("Sheet19").Range("A" & Rows.Count).End(xlUp).Offset(2)
Next i
End With
End Sub
Edit: So the suggested fix corrected the error, however now I am experiencing what i guess is an error in the logic. The script is not returning any cells to sheet18 or sheet19.
I know there should be cells returned as these cells are able to be found if looked for manually. there are no error messages and the script appears to run normally. I have stripped back the code under the previously offending script and cannot seem to locate where the error in the logic is. Maybe it has something to do with this line(?):
Set CellFound = .Find(Sh.Range("M:M").Value <= 25)
More than likely you have used Range("DateRng") -- a named range -- instead of DateRng which is really the range you have defined on the line just above, by mistake.
I suggest trying the following:
With DateRng
'...
End With
Edit:
The code following that line tells me this is definitely a mistake you have made. When you define a range object you have to use it as is. You cannot call it by passing a string with the variable name to a call to Range() (see "CellFound" for the other mistake).
Related
I have searched for this answer and many answers are close, but none of them are exactly what I need.
I need to copy the contents of 3 ranges into the clipboard and I've tried different methods to no avail. Below is an example of my code and one method...
Sub COPY_UPDATES()
Dim CopyPart1 As Range, CopyPart2 As Range, CopyPart3 As Range, AllParts As Range
Set CopyPart1 = Range("$B$2:$B$14").SpecialCells(xlCellTypeConstants)
Set CopyPart2 = Range("$A$2:$A$10000").SpecialCells(xlCellTypeConstants)
Set CopyPart3 = Range("$B$17")
Set AllParts = Union(CopyPart1, CopyPart2, CopyPart3)
'Set AllParts = Range("CopyPart1.Address, CopyPart2.Address, CopyPart3.Address")
'Set AllParts = Range(CopyPart1, CopyPart2, CopyPart3)
'Debug.Print CopyPart1 'Run-time error '13': Type mismatch
'Debug.Print CopyPart2 'Run-time error '13': Type mismatch
Debug.Print CopyPart3 'Immediate prints the value I need
'Debug.Print AllParts 'Run-time error '13': Type mismatch
AllParts.Copy 'Run-time error '1004': This action won't work on multiple selections
MsgBox "SQL UPDATES have been copied to the Clipboard." & vbNewLine & _
"Paste into SMSS (New Query) and Execute (F5)"
End Sub
The only Debug.Print that does NOT set off an error is CopyPart3, the single cell range. Taking SpecialCells out of the other two doesn't seem to matter either. I seen other cases talk about setting up a loop, but is that something I need?
Again, I have searched and searched and just cannot find this particular solution.
I just want those ranges stacked up so I can paste them all at once. Thanks!
I got what I needed using #Variatus's suggestion from the comments in my original post, which is basically copy and pasting each range into another range first, then copy that new range of combined ranges as one. Below is my new code with factors in there to clean out empty cells and format.
Sub COPY_UPDATES()
Dim CopyPart1 As Range, CopyPart2 As Range, CopyPart3 As Range, AllParts As Range
Dim CP2_LRow As Long
CP2_LRow = Cells(Rows.Count, 1).End(xlUp).Row
Set CopyPart1 = Range("$B$2:$B$12")
Set CopyPart2 = Range("$A$2:$A$" & CP2_LRow)
Set CopyPart3 = Range("$B$14")
CopyPart1.Copy
Range("$B$20:$B$32").PasteSpecial xlPasteValues 'removes cell format on paste
CopyPart2.Copy
Range("$B$33:$B$" & CP2_LRow + 32).PasteSpecial xlPasteValues 'removes cell format on paste
CopyPart3.Copy
Range("$B$" & CP2_LRow + 32 + 1).PasteSpecial xlPasteValues 'removes cell format on paste
Set AllParts = Range("$B$20:$B$" & CP2_LRow + 32 + 1)
'below copies the 3 pasted ranges over one column to remove blanks from CopyParts pastes
AllParts.SpecialCells(xlCellTypeConstants).Copy Destination:=Range("$C$20")
'delete the original 3 CopyPart pastes to shift newly copy/pasted values with no blanks to AllParts range
AllParts.Delete Shift:=xlToLeft
Dim AP_LRow As Long, AllPartsFinal As Range
AP_LRow = Cells(Rows.Count, 2).End(xlUp).Row
Set AllPartsFinal = Range("$B$20:$B$" & AP_LRow)
'last copy to clipboard to be pasted
AllPartsFinal.Copy
MsgBox "SQL UPDATES have been copied to the Clipboard." & vbNewLine & _
"Paste into SMSS (New Query) and Execute (F5)"
End Sub
I have a routine, that fills a calendar with all important events for the commodity markets for each day of the following week. I have a calendar grid laid out on the page and have ten named cells for each day i.e. Monday1, Monday2 and so on (each day only goes up to 10 for now, i.e.Monday10), in each days column. BTW the cells are 2 cells wide and 2 cells deep. Many times there are more than 10 events for a given day. I am trying to test for the named range to see if it exists, if not copy the format of the last named range cell and name that cell the next name in the series.
I am only having two issues with the above, first and foremost is how to test to determine in a name for a named range already exists. I am currently iterating thru the entire list of ThisWorkbook.Names, which has thousands of named ranges in it. Since this iteration could be running over 100 times when the calendar is generating, it is wicked slow (as would be expected). Is there a better, faster way to check if a name already exists as a named range?
The second issue is how to copy the formatting of a 4 cell, merged cell, since the address always comes up as only the top left corner cell so offsetting the range doesn't work appropriately. I hacked around to get this code to at least come up with the right range for the next merged cell group in the column
Set cCell = Range("Thursday" & CStr(y))
'even tho cCell is a 4 cell merged cell, cCell.Address returns the address of top left cell
Set destRange = Range(cCell.Address & ":" & cCell.offset(2, 0).offset(0, 1).Address)
Recording a macro to drag the formatting down, shows this code.
Range("G22:H23").Select
Selection.AutoFill Destination:=Range("G22:H25"), Type:=xlFillFormats
Range("G22:H25").Select
Since Range("G22:H23") is the same as cCell, and Range("G22:H25") is the same as destRange. The following code should work, but doesn't.
Set cCell = Range("Thursday" & CStr(y))
Set destRange = Range(cCell.Address & ":" & cCell.offset(2, 0).offset(0, 1).Address)
cCell.AutoFill Destination:=destRange, Type:=xlFillFormats
Application.CutCopyMode = False
cCell.offset(1, 0).Name = rangeName
FYI, it doesn't work if I select cCell and use Selection.AutoFill either.
Any thoughts on how to copy that cell formatting down the column one cell at a time when needed?
Update:
This now works for copying the formatting down from one merged cell to another of same size. For some reason setting destRange to the whole range (the copy cell and pastecell entire range as the macro recorder showed) didnt work but setting destRange to the cell range that needed formatting, and then doing a union of cCell and destRange worked, and made naming the new range easier.
rangeName = "Friday" & CStr(y + 1)
priorRangeName = "Friday" & CStr(y)
namedRangeExist = CheckForNamedRange(rangeName)
If namedRangeExist = False Then
Set cCell = Range(priorRangeName)
Set destRange = Range(cCell.offset(1, 0).Address & ":" & cCell.offset(2, 0).offset(0, 1).Address)
cCell.AutoFill Destination:=Union(cCell, destRange), Type:=xlFillFormats
Application.CutCopyMode = False
destRange.Name = rangeName
End If
Update #2
There is an issue with naming ranges in a For loop ( the code below is running inside a For loop). The first time the new rangeName is not found, Setting cCell to the prior range name and running through the code to copy the merged cell format and name the new range works fine. Here is the code
rangeName = "Thursday" & CStr(y + 1)
priorRangeName = "Thursday" & CStr(y)
namedRangeExist = DoesNamedRangeExist(rangeName)
If namedRangeExist = False Then
Set cCell = Range(priorRangeName)
Debug.Print "cCell:" & cCell.Address
Set cCell = cCell.MergeArea
Debug.Print "Merged cCell:" & cCell.Address
Set destRange = Range(cCell.offset(1, 0).Address & ":" & cCell.offset(2, 0).offset(0, 1).Address)
Debug.Print "Dest:" & destRange.Address
Debug.Print "Unioned:" & Union(cCell, destRange).Address
cCell.AutoFill Destination:=Union(cCell, destRange), Type:=xlFillFormats
Application.CutCopyMode = False
destRange.name = rangename
End If
results in the following ranges
cCell:$G$22
Merged cCell:$G$22:$H$23
Dest:$G$24:$H$25
Unioned:$G$22:$H$25
but if more than one new named range needs to be created the second time thru this code produces a range area as evidenced by the output shown below
cCell:$G$24:$H$25
so why does cCell's address show as only the upper left cells address when run the first time, but the second time thru cCell's address is shown as the whole merged cell range? And because it does, the next code line produces a range object error
Set cCell = cCell.MergeArea
Eliminating that code line and amending the first Set cCell to this;
Set cCell = Range(priorRangeName).MergeArea
produces the same error. I could kludge this by setting a counter, and if more than one, bypass that code line but that is not the preferred solution.
First and foremost, create a function to call the named range. If calling the named range generate an error the function will return False otherwise it will return True.
Function NameExist(StringName As String) As Boolean
Dim errTest As String
On Error Resume Next
errTest = ThisWorkbook.Names(StringName).Value
NameExist = CBool(Err.Number = 0)
On Error GoTo 0
End Function
As for your second question, I had not problem with the autofill.
I would replce Set destRange = Range(cCell.Address & ":" & cCell.offset(2, 0).offset(0, 1).Address) with Set destRange = cCell.Resize(2,1). It has the same effect but the later is much cleaner.
Application.Evaluate and Worksheet.Evaluate can be used to get error value instead of error :
If Not IsError(Evaluate("Monday1")) Then ' if name Monday1 exists
The error can be ignored or jumped over (but that can result in hard to detect errors) :
On Error GoTo label1
' code that can result in error here
label1:
If Err.Number <> 0 Then Debug.Print Err.Description ' optional if you want to check the error
On Error GoTo 0 ' to reset the error handling
Range.MergeArea can be used to get the Range of merged cell.
I created a function to extend the name ranges and fill in the formatting. The first named range in the series will have to be setup. The Name itself needs to be set to the top left cell in the merged area.
ExtendFillNamedRanges will calculate the positions of the named ranges. If a cell in one of the positions isn't part of a MergedArea it will fill the formatting down from the last named range. It will name that cell. The scope of the names is Workbook.
Sub ExtendFillNamedRanges(BaseName As String, MaxCount As Integer)
Dim x As Integer, RowCount As Integer, ColumnCount As Integer
Dim LastNamedRange As Range, NamedRange As Range
Set NamedRange = Range(BaseName & 1)
RowCount = NamedRange.MergeArea.Rows.Count
ColumnCount = NamedRange.MergeArea.Columns.Count
For x = 2 To MaxCount
Set NamedRange = NamedRange.Offset(RowCount - 1)
If Not NamedRange.MergeCells Then
Set LastNamedRange = Range(BaseName & x - 1).MergeArea
LastNamedRange.AutoFill Destination:=LastNamedRange.Resize(RowCount * 2, ColumnCount), Type:=xlFillDefault
NamedRange.Name = BaseName & x
End If
'NamedRange.Value = NamedRange.Name.Name
Next
End Sub
Here is the test that I ran.
Sub Test()
Application.ScreenUpdating = False
Dim i As Integer, DayName As String
For i = 1 To 7
DayName = WeekDayName(i)
Range(DayName & 1).Value = DayName & 1
ExtendFillNamedRanges DayName, 10
Next i
Application.ScreenUpdating = True
End Sub
Before:
After:
I found this on ozgrid and made a little function out of it:
Option Explicit
Function DoesNamedRangeExist(VarS_Name As String) As Boolean
Dim NameRng As Name
For Each NameRng In ActiveWorkbook.Names
If NameRng.Name = VarS_Name Then
DoesNamedRangeExist = True
Exit Function
End If
Next NameRng
DoesNamedRangeExist = False
End Function
You can put this line in your code to check:
DoesNamedRangeExist("Monday1")
It will return a Boolean value (True / False) so it's easy to use with an IF() statement
As to your question on merged cells, I did a quick macro record on a 2*2 merged cell and it gave me this (made smaller and added comments):
Sub Macro1()
Range("D2:E3").Copy 'Orignal Merged Cell
Range("G2").PasteSpecial xlPasteAll 'Top left of destination
End Sub
I am a new user of VBA and am trying to do the following (I got stuck towards the end):
I need to locate the first empty cell across every row from column C to P (3 to 16), take this value, and paste it in the column B of the same row.
What I try to do was:
Find non-empty cells in column C, copy those values into column B.
Then search for empty cells in column B, and try to copy the first non-empty cell in that row.
The first part worked out fine, but I am not too sure how to copy the first non-empty cell in the same row. I think if this can be done, I might not need the first step. Would appreciate any advice/help on this. There is the code:
Private Sub Test()
For j = 3 To 16
For i = 2 To 186313
If Not IsEmpty(Cells(i, j)) Then
Cells(i, j - 1) = Cells(i, j)
End If
sourceCol = 2
'column b has a value of 2
RowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
'for every row, find the first blank cell, copy the first not empty value in that row
For currentRow = 1 To RowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If Not IsEmpty(Cells(i, 3)) Or Not IsEmpty(Cells(i, 4)) Or Not IsEmpty(Cells(i, 5)) Or Not IsEmpty(Cells(i, 6)) Then
Paste
~ got stuck here
Next i
Next j
End Sub
Your loop is really inefficient as it is iterating over millions of cells, most of which don't need looked at. (16-3)*(186313-2)=2,422,043.
I also don't recommend using xlUp or xlDown or xlCellTypeLastCell as these don't always return the results you expect as the meta-data for these cells are created when the file is saved, so any changes you make after the file is saved but before it is re-saved can give you the wrong cells. This can make debugging a nightmare. Instead, I recommend using the Find() method to find the last cell. This is fast and reliable.
Here is how I would probably do it. I'm looping over the minimum amount of cells I can here, which will speed things up.
You may also want to disable the screenupdating property of the application to speed things up and make the whole thing appear more seemless.
Lastly, if you're new to VBA it's good to get in the habit of disabling the enableevents property as well so if you currently have, or add in the future, any event listeners you will not trigger the procedures associated with them to run unnecessarily or even undesirably.
Option Explicit
Private Sub Test()
Dim LastUsed As Range
Dim PasteHere As Range
Dim i As Integer
Application.ScreenUpdating=False
Application.EnableEvents=False
With Range("B:B")
Set PasteHere = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
If PasteHere Is Nothing Then Set PasteHere = .Cells(1, 1) Else: Set PasteHere = PasteHere.Offset(1)
End With
For i = 3 To 16
Set LastUsed = Cells(1, i).EntireColumn.Find("*", Cells(1, i), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
If Not LastUsed Is Nothing Then
LastUsed.Copy Destination:=PasteHere
Set PasteHere = PasteHere.Offset(1)
End If
Set LastUsed = Nothing
Next
Application.ScreenUpdating=True
Application.EnableEvents=True
End Sub
Sub non_empty()
Dim lstrow As Long
Dim i As Long
Dim sht As Worksheet
Set sht = Worksheets("Sheet1")
lstrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
For i = 1 To lstrow
If IsEmpty(Range("B" & i)) Then
Range("B" & i).Value = Range("B" & i).End(xlToRight).Value
End If
Next i
End Sub
I don't understand syntax for range.
Why does this work:
For i = 1 To 10
Range("A" & i & ":D" & i).Copy
Next
But this doesn't work:
For i = 2 To lastRow
num = WorksheetFunction.Match(Cells(i, 1), Range("A" & lastRow), 0)
Next
Why do I need to use
For i = 2 To lastRow
'num = WorksheetFunction.Match(Cells(i, 1), Range("A1:A" & lastRow), 0)
Next
What A1:A mean? Why can't I use
Range("A" & lastRow), 0
There is nothing wrong with your syntax and your code should've work just fine.
The problem with using worksheet function like Match, Vlookup and other look up functions is that if the value being searched is not found, it throws up an error.
In your case, you are trying to search multiple values in just one cell.
So let us say your lastrow is 9. You're code will loop from Cell(2,1) to Cell(9,1) checking if it is within Range("A" & lastrow) or Range("A9").
If your values from Cell(2,1) through Cell(9,1) is the same as your value in Range("A9"), you won't get an error.
Now, if you use Range("A1:A" & lastrow), it will surely work cause you are trying to match every element of that said range to itself and surely a match will be found.
WorksheetFunction.Match(Cells(2,1), Range("A1:A9")) 'will return 2
WorksheetFunction.Match(Cells(3,1), Range("A1:A9")) 'will return 3
'
'
'And so on if all elements are unique
It doesn't matter if you use Range("A9") or Range("A1:A9").
What matters is that you handle the error in case you did not find a match.
One way is to use On Error Resume Next and On Error Goto 0 like this:
Sub ject()
Dim num As Variant
Dim i As Long, lastrow As Long: lastrow = 9
For i = 2 To lastrow
On Error Resume Next
num = WorksheetFunction.Match(Cells(i, 1), Range("A" & lastrow), 0)
If Err.Number <> 0 Then num = "Not Found"
On Error GoTo 0
Debug.Print num
Next
End Sub
Another way is to use Application.Match over WorksheetFunction.Match like this:
Sub ject()
Dim num As Variant
Dim i As Long, lastrow As Long: lastrow = 9
For i = 2 To lastrow
num = Application.Match(Cells(i, 1), Range("A" & lastrow), 0)
Debug.Print num
'If Not IsError(num) Then Debug.Print num Else Debug.Print "Not Found"
Next
End Sub
Application.Match works the same way but it doesn't error out when it returns #N/A. So you can assign it's value in a Variant variable and use it later in the code without any problem. Better yet, use IsError test to check if a value is not found as seen above in the commented lines.
In both cases above, I used a Variant type num variable.
Main reason is for it to handle any other value if in case no match is found.
As for the Range Syntax, don't be confused, it is fairly simple.
Refer to below examples.
Single Cell - All refer to A1
Cells(1,1) ' Using Cell property where you indicate row and column
Cells(1) ' Using cell property but using just the cell index
Range("A1") ' Omits the optional [Cell2] argument
Don't be confused with using cell index. It is like you are numbering all cells from left to right, top to bottom.
Cells(16385) ' refer to A2
Range of contiguous cell - All refer to A1:A10
Range("A1:A10") ' Classic
Range("A1", "A10") ' or below
Range(Cells(1, 1), Cells(10, 1))
Above uses the same syntax Range(Cell1,[Cell2]) wherein the first one, omits the optional argument [Cell2]. And because of that, below also works:
Range("A1:A5","A6:A10")
Range("A1", "A8:A10")
Range("A1:A2", "A10")
Non-Contiguous cells - All refer to A1, A3, A5, A7, A9
Range("A1,A3,A5,A7,A9") ' Classic
Without any specific details about the error, I assume that Match does not return the value you expect, but rather an #N/A error. Match has the syntax
=match(lookup_value, lookup_range, match_type)
The lookup_range typically consists of a range of several cells, either a column with several rows or a row with several columns.
In your formula, you have only one cell in the lookup_range. Let's say Lastrow is 10. The first three runs of the loop produce the formula
=Match(A2,A10,0)
=Match(A3,A10,0)
=Match(A4,A10,0)
It is a valid formula but in most cases the result won't be a match but an error. Whereas what you probably want is
=Match(A2,A1:A10,0)
Looking again at your code, stitch it together and find why you need A1:A as a string constant in your formula:
For i = 2 To lastRow
num = WorksheetFunction.Match(Cells(i, 1), Range("A1:A" & lastRow), 0)
Next
Please help! I've a problem that I've been stuck with for the past day.
I need to transfer data from one sheet to another sheet in another workbook. The output row corresponds to a value in input column a, and output column corresponds to a date in input sheet column B.
I've previously dim-ed the input/out workbooks/sheets as wbin,wbout,sheetin,sheetout respectively. Could anyone help see where my problem is? The error I get is runtime error '9': subscript out of range in the copy destination line.
Windows(wbin).Activate
Sheets(sheetin).Select
iMaxRow = 5000
Dim subj1 As String
Dim subj2 As String
For iRow = 1 To iMaxRow
subj1 = Range("B" & iRow).Text
subj2 = Range("A" & iRow).Text
With Workbooks(wbin).Sheets(sheetin).Cells(iRow, 3)
'On Error Resume Next
.Copy Destination:=Workbooks(wbout).Worksheets(sheetout).Cells(WorksheetFunction.Match(subj2 & "*", _
Workbooks(wbout).Sheets(sheetin).Columns(2), 0) & _
WorksheetFunction.Match(subj1, Workbooks(wbout).Sheets(sheetin).Rows(2), 0) + 1)
End With
Next iRow
For now, i've disabled the on error resume next. Also, the input column a has 4 numbers followed by string, while the corresponding output row header only has the 4 numbers, hence I tried matching with the wildcard.
Any advice would be really appreciated!
This is the correct way to solve your problem. You need to use 'Range.Find' instead of 'WorksheetFunction.Match'.
Dim dateHeader as Range, foundCell as Range
Set dateHeader = Workbooks(wbout).Worksheets(sheetout).Rows(2)
Set foundCell = dateHeader.Find(subj1)
.Copy Intersect(foundCell.EntireColumn, Workbooks(wbout).Worksheets(sheetout).Rows(subj2))