I want column S to multiply the value of column G and column R until the last row of my data set (The length of the data set varies). Does anyone know how to go about this? Currently, I am trying things like:
Dim LastRow As Long, d As Long
LastRow = Cells(Rows.Count, "U").End(xlUp).Row
For d = 2 To LastRow
If Range("U" & d).Value = "" Then Set rw.Columns("S") = rw.Columns("F").Value * rw.Columns("R").Value * 0.01
Next d
But they don't work. It does not seem that difficult to me, but I still can't figure it out. I would really appreciate any help!
Please, try using the next code. You did not answer my clarification question, so it works on the assumption that the column S:S is filled with the multiplication result only for empty cells in column U:U. If not an empty cell, a null string will be filled. If already there are values in S:S, which must be kept, please state that and I will adapt the code to keep them:
Sub FillSSColl()
Dim sh As Worksheet, lastR As Long, rngS As Range
Set sh = ActiveSheet
lastR = sh.Range("U" & sh.rows.count).End(xlUp).row
Set rngS = sh.Range("S2:S" & lastR)
rngS.value = Application.Evaluate("=If(" & rngS.Offset(0, 2).Address(0, 0) & "= """"," & _
rngS.Offset(0, -13).Address(0, 0) & " * " & rngS.Offset(0, -1).Address(0, 0) & " * 0.01,"""")")
End Sub
But your question meaning in words does not match your code attempt...
If you want the code to calculate if row contains any value, as the title states, the code should be modified from If(" & rngS.Offset(0, 2).Address(0, 0) & "= """"," in If(" & rngS.Offset(0, 2).Address(0, 0) & "<> """",". I tried following what I could deduce looking to your code.
Edited:
Please, try the version filling all S:S column for the U:U column filled range:
Sub FillSSColl_bis()
Dim sh As Worksheet, lastR As Long, rngS As Range
Set sh = ActiveSheet
lastR = sh.Range("U" & sh.rows.count).End(xlUp).row
Set rngS = sh.Range("S2:S" & lastR)
rngS.value = Application.Evaluate(rngS.Offset(0, -13).Address(0, 0) & " * " & rngS.Offset(0, -1).Address(0, 0) & " * 0.01")
End Sub
Related
New to VBA, so please be patient with me :)
I created a program to loop through the columns in a named range and, if the cell is not blank, transfer
and organize certain information from that column into a table on another sheet. I seem to be encountering an error with the offset ranges. Please let me know if you have any suggestions. Thank you!
Dim PTMsht As Worksheet
Set PTMsht = Sheets("PTM")
Dim TRNsht As Worksheet
Set TRNsht = Sheets("LIST")
Dim TRN_lastrow As Long
TRN_lastrow = TRNsht.Range("J" & TRNsht.Rows.Count).End(xlUp).Row + 1
Dim PTM_lastrow As Long
PTM_lastrow = PTMsht.Range("D" & PTMsht.Rows.Count).End(xlUp).Row
Dim col As Range
For Each col In PTMsht.Range("DOC_TITLE")
If col.Value <> vbnullstring Then
TRNsht.Range("K" & TRN_lastrow & ":K" & (TRN_lastrow + (PTM_lastrow - 9))).Value = Application.WorksheetFunction.Transpose(PTMsht.Range(col.Offset(9, 0), col.Offset(PTM_lastrow, 0)).Value)
TRNsht.Range("D" & TRN_lastrow & ":I" & (TRN_lastrow)).Value = Application.WorksheetFunction.Transpose(PTMsht.Range(col.Offset(1, 0).Address, col.Offset(6, 0).Address))
TRNsht.Range("J" & TRN_lastrow).Value = Application.WorksheetFunction.Transpose(PTMsht.Range(col.Offset(0, 0), col.Offset(0, 0)))
TRNsht.Range("B" & TRN_lastrow & ":C" & (TRN_lastrow + 135)).Value = Application.WorksheetFunction.Transpose(PTMsht.Range("D15:E" & PTM_lastrow))
End If
Next col
Beforehand, be aware that I just began using VBA, and I have few coding experience prior to it.
I have two sheets:
public
contacts
There is one parameter on column A that is definitely on "contacts" sheet, but may be or not be on column A on "public" sheet.
What I'm doing is:
Checking if the parameter contacts.A2 is on public.A2.
If it is, I need to copy columns, on the exact order:
public: A, C, G.
contacts: E, F.
I've found the following code online, and I'm running some adaptations to it, but I'm stuck.
Sub match()
Dim I, total, frow As Integer
Dim found As Range
total = Sheets("public").Range("A" & Rows.Count).End(xlUp).Row
'MsgBox (total) '(verifica se a contagem está ok)
For I = 2 To total
pesquisa = Worksheets("public").Range("A" & I).Value
Set found = Sheets("contacts").Columns("A:A").Find(what:=pesquisa) 'finds a match
If found Is Nothing Then
Worksheets("result").Range("W" & I).Value = "NO MATCH"
Else
frow = Sheets("contacts").Columns("A:A").Find(what:=pesquisa).Row
Worksheets("result").Range("A" & I).Value = Worksheets("public").Range("A" & frow).Value
Worksheets("result").Range("B" & I).Value = Worksheets("public").Range("C" & frow).Value
Worksheets("result").Range("C" & I).Value = Worksheets("public").Range("G" & frow).Value
Worksheets("result").Range("D" & I).Value = Worksheets("contacts").Range("F" & frow).Value
Worksheets("result").Range("E" & I).Value = Worksheets("contacts").Range("G" & frow).Value
End If
Next I
End Sub
What I expect:
to the code do ignore the line 1, as those are headers;
to eliminate de IF above, since I don't need the "NO MATCH"
to the resulting list to be ordered on ascending order, based on the A column.
Can you help me?
edited to include samples of the data and expected results:
I believe I can simplify my needs with the images above. I want to check a client on the public sheet, grab the manager contacts (emails) from the contacts sheet, and create a list that contains branch, manager, and both e-mails on the results sheet.
Creating those images, I realized I have forgotten to account for the second parameter (manager), as there can be multiple managers on a branch. So this is another parameter to account for.
`Public sheet (image)
Contacts sheet(image)
Result sheet(image)
spreadsheet
`
As per my comments, and your updated question with sample, I do believe that your current results do not match that what you say is required; which is looking for both parameters "Branch" and "Manager". Neither does your expected result look like the columns you wanted to extract according to your question. However, going by your sample data and expected output I tried the following:
Sub BuildList()
'Define your variables
Dim x As Long, y As Long
Dim arr1 As Variant, arr2 As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
'Fill 1st array variable from sheet Contacts
With Sheet1 'Change accordingly
x = .Cells(.Rows.Count, 1).End(xlUp).Row
arr1 = .Range("A2:D" & x).Value
End With
'Fill dictionary with first array
For x = LBound(arr1) To UBound(arr1)
dict.Add arr1(x, 1) & "|" & arr1(x, 2), arr1(x, 3) & "|" & arr1(x, 4)
Next x
'Fill 2nd array variable from sheet Public
With Sheet2 'Change accordingly
x = .Cells(.Rows.Count, 1).End(xlUp).Row
arr2 = .Range("A2:B" & x).Value
End With
'Compare array against dictionary and fill sheet Results
With Sheet3 'Change accordingly
y = 2
For x = LBound(arr2) To UBound(arr2)
If dict.Exists(arr2(x, 1) & "|" & arr2(x, 2)) Then
.Cells(y, 1).Value = arr2(x, 1)
.Cells(y, 2).Value = arr2(x, 2)
.Cells(y, 3).Value = Split(dict(arr2(x, 1) & "|" & arr2(x, 2)), "|")(0)
.Cells(y, 4).Value = Split(dict(arr2(x, 1) & "|" & arr2(x, 2)), "|")(1)
y = y + 1
End If
Next x
End With
End Sub
This solution makes use of arrays and dictionary which should be fast. It has given me the following result:
As David suggested, it would be better to have an input and output sample. Maybe you can try this:
Option Explicit
Public Sub match()
Dim wsPub As Worksheet
Dim wsCon As Worksheet
Dim wsRes As Worksheet
Dim pubRow As Long
Dim conRow As Long
Dim resRow As Long
Dim i As Long
Dim rng As Range
Dim cel As Range
Dim found As Long
Dim order(1 To 5) As Integer
Set wsPub = ThisWorkbook.Worksheets("public")
Set wsCon = ThisWorkbook.Worksheets("contacts")
Set wsRes = ThisWorkbook.Worksheets("result")
pubRow = wsPub.Cells(wsPub.Rows.Count, 1).End(xlUp).Row
conRow = wsCon.Cells(wsPub.Rows.Count, 1).End(xlUp).Row
resRow = wsRes.Cells(wsRes.Rows.Count, 1).End(xlUp).Row
Set rng = wsPub.Range("A2:A" & pubRow)
order(1) = 1
order(2) = 3
order(3) = 7
order(4) = 6
order(5) = 7
For Each cel In rng
If Not IsError(Application.match(cel.Value, wsCon.Range("A2:A" & conRow), 0)) Then
found = Application.match(cel.Value, wsCon.Range("A2:A" & conRow), 0) + 1
resRow = wsRes.Cells(wsRes.Rows.Count, 1).End(xlUp).Row
For i = 1 To 5
If i < 4 Then
wsRes.Cells(resRow, i).Offset(1, 0).Value _
= cel.Offset(0, order(i) - 1).Value
Else
wsRes.Cells(resRow, i).Offset(1, 0).Value _
= wsCon.Cells(found, order(i)).Value
End If
Next
End If
Next
wsRes.Range("A1").AutoFilter
wsRes.AutoFilter.Sort.SortFields.Clear
wsRes.AutoFilter.Sort.SortFields.Add2 Key:= _
Range("A1:A" & resRow), SortOn:=xlSortOnValues, order:=xlAscending, DataOption:= _
xlSortNormal
wsRes.AutoFilter.Sort.Apply
End Sub
I'm new to VBA so sorry if this seems to be a simple question.
I'm trying to create a macro which will formate and include a couple of formulas in a sheet but when I try to include the formula until the last row I get a error "Run Time Error 1004 - Application-Defined or Object Defined Error" at the following code:
ActiveSheet.Range("U2:U" & LastRow).Formula = "=L2/86400"
If I change the "Last Row" for a number the Macro works normally. Below is the whole code.
Sheets("DLASpotPlacement").Select
Dim LastRow As Double
LastRow = Sheets("DLASpotPlacement").Cells(Rows.Count, 1).Rows
Range("A1").Select
ActiveSheet.Range("U:U, V:V, W:W").NumberFormat = "[h]:mm:ss;#"
ActiveSheet.Range("U2:U" & LastRow).Formula = "=L2/86400"
ActiveSheet.Range("V2:V" & LastRow).Formula = "=VALUE(H2)"
ActiveSheet.Range("W2:W" & LastRow).FormulaLocal = "=IF(AND(H2>0,0416666666666667;H2<=0,249988425925926);""01 - 06"";IF(AND(H2>=0,25;H2<0,4166551);""06 - 10"";IF(AND(H2>=0,4166667;H2<0,4999884);""10 - 12"";IF(AND(H2>=0,5;H2<0,7499884);""12 - 18"";""18 - 01""))))"
Thanks for all the help
Copy Excel Formulas
The error occurs because of two reasons:
You forgot End(xlUp) in the LastRow Calculation, e.g.:
LastRow = Sheets("DLASpotPlacement").Cells(Rows.Count, 1).End(xlUp).Row
and it has to be declared as a whole number e.g.:
Dim LastRow as Long
The Code
Option Explicit
Sub CopyFormulas()
Const cCol As Variant = "A" ' Last Row Column Letter/Number
Const cFirstR As Long = 2 ' First Row Number
Dim LastRow As Long ' Last Row Number
With ThisWorkbook.Worksheets("DLASpotPlacement")
LastRow = .Cells(.Rows.Count, cCol).End(xlUp).Row
'.Cells(1, cCol).Select ' uncomment if necessary
' You don't need to format the entire columns.
.Range("U" & cFirstR & ":W" & LastRow).NumberFormat = "[h]:mm:ss;#"
.Range("U" & cFirstR & ":U" & LastRow).Formula = "=L2/86400"
.Range("V" & cFirstR & ":V" & LastRow).Formula = "=VALUE(H2)"
.Range("W" & cFirstR & ":W" & LastRow).FormulaLocal = _
"=IF(AND(H2>0,0416666666666667;H2<=0,249988425925926);""" _
& "01 - 06"";IF(AND(H2>=0,25;H2<0,4166551);""06 - 10"";IF(" _
& "AND(H2>=0,4166667;H2<0,4999884);""10 - 12"";IF(AND(H2>=0" _
& ",5;H2<0,7499884);""12 - 18"";""18 - 01""))))"
End With
End Sub
Remarks
Using FormulaLocal is a nice 'trick' to remember.
#Mike; Your problem is in this line:
LastRow = Sheets("DLASpotPlacement").Cells(Rows.Count, 1).Rows
You made the LastRow an array, not a number. Also, is not a Double but an Iteger (mathematically). However, the Integer datatype is too small and you will get an "Overflow" error if you declare it "As Integer". Here are the two changes you need to make it all work:
Dim LastRow As Long
LastRow = Sheets("DLASpotPlacement").Rows.Count
...
For LastRow, use the Worksheet.UsedRange property.
You could also use the Range.Resize property to select the range, and replace the "Select" with "With".
Dim LastRow As Double
With Sheets("DLASpotPlacement")
LastRow = .UsedRange.Rows.count
.Range("U:W").NumberFormat = "[h]:mm:ss;#"
.Range("U1").Resize(LastRow - 1).Formula = "=L2/86400"
.Range("V1").Resize(LastRow - 1).Formula = "=VALUE(H2)"
.Range("W1").Resize(LastRow - 1).FormulaLocal = "..."
End With
I am not entirely sure how to phrase this question. However, I will be able to explain it better here. Below is my code. The purpose of my code is to copy and paste data from one sheet to another.
Everything seems to work fine up until it gets to the very last line of code (excluding "End Sub"). The last line is supposed to fill down to the last row. The issue I am getting is that the code works fine if I break up the With statement and the final line and run them separately.
I know the last line works but when I run the entire macro, I get a "Run time Error '1004" error message. Why does my code not work?
Sub Data_Table()
Dim Data As Worksheet
Dim Sum As Worksheet
Dim lr As Long
Dim lr2 As Long
Dim lr3 As Long
Dim lr4 As Long
Dim lr5 As Long
Set Data = Worksheets("Data-Tracker")
Set Sum = Worksheets("Summary")
lr = Data.Cells(Rows.Count, "E").End(xlUp).Row
lr2 = Data.Cells(Rows.Count, "A").End(xlUp).Row 'for customer type
lr3 = Data.Cells(Rows.Count, "B").End(xlUp).Row ' for Type
lr4 = Data.Cells(Rows.Count, "C").End(xlUp).Row ' for Rate/Budget
lr5 = Data.Cells(Rows.Count, "D").End(xlUp).Row ' for Date
With Sum
.Range("B6:B12").Copy Destination:=Data.Range("E" & lr).Offset(1, 0)
.Range("C6:C12").Copy Destination:=Data.Range("F" & lr).Offset(1, 0)
.Range("D6:D12").Copy Destination:=Data.Range("G" & lr).Offset(1, 0)
.Range("C2").Copy Destination:=Data.Range("B" & lr3).Offset(1, 0)
.Range("B4").Copy Destination:=Data.Range("C" & lr4).Offset(1, 0)
.Range("B5").Copy Destination:=Data.Range("D" & lr5).Offset(1, 0)
End With
Data.Range("B" & lr3, "D" & lr5).AutoFill Destination:=Data.Range("B" & lr3, "D" & lr)
End Sub
Any help would be greatly appreciated.
EDIT:
To help further explain my point, if I first run my code like this:
With Sum
.Range("B6:B12").Copy Destination:=Data.Range("E" & lr).Offset(1, 0)
.Range("C6:C12").Copy Destination:=Data.Range("F" & lr).Offset(1, 0)
.Range("D6:D12").Copy Destination:=Data.Range("G" & lr).Offset(1, 0)
.Range("C2").Copy Destination:=Data.Range("B" & lr3).Offset(1, 0)
.Range("B4").Copy Destination:=Data.Range("C" & lr4).Offset(1, 0)
.Range("B5").Copy Destination:=Data.Range("D" & lr5).Offset(1, 0)
End With
' Data.Range("B" & lr3 & ":D" & lr5).AutoFill Destination:=Data.Range("B" & lr3, "D" & lr)
And then after run it like:
' With Sum
'
' .Range("B6:B12").Copy Destination:=Data.Range("E" & lr).Offset(1, 0)
' .Range("C6:C12").Copy Destination:=Data.Range("F" & lr).Offset(1, 0)
' .Range("D6:D12").Copy Destination:=Data.Range("G" & lr).Offset(1, 0)
' .Range("C2").Copy Destination:=Data.Range("B" & lr3).Offset(1, 0)
' .Range("B4").Copy Destination:=Data.Range("C" & lr4).Offset(1, 0)
' .Range("B5").Copy Destination:=Data.Range("D" & lr5).Offset(1, 0)
'
'
' End With
Data.Range("B" & lr3 & ":D" & lr5).AutoFill Destination:=Data.Range("B" & lr3, "D" & lr)
I have to add the apostrophes in to cancel the code out in order for it to work. Otherwise I get a Autofill Method error.
There are two things you need to do.
The first and the obvious one is to fix the syntax in the line in question: a Range Address needs to be indicated in both Source and Destination, not the corners: ...lr3 & ":D"... and not this ...lr3, "D"...
The second one is to make sure that the Destination is always taller than the source, just in case:
If lr > lr5 Then
Data.Range("B" & lr3 & ":D" & lr5).AutoFill ....
End If
I suggest replacing the Range().Copy Destination:= statements with absolute referencing with relative referencing and the direct assignment of multiple values in one statement.
I think your intent is to append to the Summary worksheets with values from Data.
Say you have n cells under E2 in the Data page that you want to be copied under the k-th cell in Summary page under B2. You do that with
Sum.Range("B2").Cells(k,1).Resize(n,1).Value = Data.Range("E2").Resize(n,1).Value
The trick is reference one cell and then use the .Resize() statement to expand the selection into a whole table (multiple rows and columns) if needed. The use the .Value assignment to move all the values in one statement.
I am having problems copy/pasting rows based on criteria.
Dim lastrow1 As Long
Dim lastcolumn1 As Long
Dim Distance As Long
Distance = 14
Set sh = ThisWorkbook.Sheets("Sample Address Database")
Set sh2 = ThisWorkbook.Sheets("Workspace")
lastrow1 = sh.Cells(Rows.Count, "A").End(xlUp).row
lastcolumn1 = sh.Cells(1, Columns.Count).End(xlToLeft).Column
Dim L As Long
For L = 2 To lastrow1
If _
sh.Cells(L, Distance).Value <= CDbl(cboRadius.Value) Then
sh.Range("A" & L & ":" & lastcolumn1 & L).Copy _
Destination:=sh2.Range("A" & L)
End If
Next
cboRadius.Value is a number from a userform (there is no problem with that line.)
Whenever I try to run this code, I get a "Run-time error '1004': Method 'Range' of object '_Worksheet' failed, with the yellow arrow pointing to the destination line. What is the problem?
EDIT:
Ed Heywood-Lonsdale suggested I change
sh.Range("A" & L & ":" & lastcolumn1 & L).Copy _
To
sh.Range("A" & L & ":A" & lastcolumn1 & L).Copy _
Now only column A, or if I change it to B, C, D, etc. is being copied. I think the problem is that it may not be registering that lastcolumn1 and L are column/row numbers and is instead making them one value, thus causing a range malfunction.
Try adding "A" when defining the range to be copied:
sh.Range("A" & L & ":" & lastcolumn1 & L)
becomes
sh.Range("A" & L & ":A" & lastcolumn1 & L)
I would just filter your data in place using the built in Excel Filters, then copy the results over instead of trying to Loop over every row.
BUT If you want to loop the rows anyways:
In order to use the Range function you need to use column letters not column numbers.
You have 2 options here. Use
Chr(lastcolumn1 + 64)
instead of lastcolumn1. The flaw is This will only work for columns up to columns Z, and it won't work for double letter columns without an if statement and more code. Like the following should work for up to Column ZZZ
If lastcolumn1> 52 Then
strColumnLetter = Chr(Int((lastcolumn1- 1) / 52) + 64) & Chr(Int((lastcolumn1- 27) / 26) + 64) & Chr(Int((lastcolumn1- 27) Mod 26) + 65)
ElseIf lastcolumn1> 26 Then
strColumnLetter = Chr(Int((lastcolumn1- 1) / 26) + 64) & Chr(Int((lastcolumn1- 1) Mod 26) + 65)
Else
strColumnLetter = Chr(lastcolumn1+ 64)
End If
But you could also use
strColumnLetter = Split(Cells(1, lastcolumn1).EntireColumn.Address(False, False), ":")(0)
OR
strColumnLetter = Left(Replace(Cells(1, lastcolumn1).Address(1, 0), "$", ""), InStr(1, Replace(Cells(1, lastcolumn1).Address(1, 0), "$", ""), 1) - 1)
OR
strColumnLetter = Left(Cells(1, lastcolumn1).Address(1, 0), InStr(1, Cells(1, lastcolumn1).Address(1, 0), "$") - 1)
as that will work for as many columns as Excel will hold.
Your last option if you don't want to convert the number to the column Letter would be to get a range of Cells, as the Cells function CAN accept column numbers for arguments.
sh.Range(cells(L,1), cells(L,lastcolumn1))
Again I would suggest just using the standard built in filter function to filter out the data you don't want then just copy whats left though. This was just to add more options.
If you supply some sample info I could write you a sub that will do the filter copy paste for you but I don't know how your data is set up.
here is an example that should work based on your Original Question:
Sub FilterAndCopy()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim sh As Worksheet, sh2 As Worksheet
Dim lastrow1 As Long
Dim lastcolumn1 As Long
Dim Distance As Long
Distance = 14
Set sh = ThisWorkbook.Sheets("Sample Address Database")
Set sh2 = ThisWorkbook.Sheets("Workspace")
lastrow1 = sh.Cells(Rows.Count, "A").End(xlUp).Row
lastcolumn1 = sh.Cells(1, Columns.Count).End(xlToLeft).Column
With sh
.Range(.Cells(1, 1), .Cells(lastrow1, lastcolumn1)).AutoFilter , _
field:=Distance, _
Criteria1:="<=" & CDbl(151), _
Operator:=xlAnd
.Range(.Cells(2, 1), .Cells(lastrow1, lastcolumn1)).Copy _
sh2.Range("A2")
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub