I am using below code to copy 4 columns of data from range A:D till the end of that row by checking a condition on B column whether its primary or backup. If primary category code will paste the data into columns K:N, if backup category paste the entire row to P:S columns.
But when executing I am getting Object Defined Error. Can anybody help with whats wrong in this code ? Thanks
Public Sub CopyData()
Dim rngSinglecell As Range
Dim rngQuantityCells As Range
Dim intCount As Integer
Range("K2:S1400").Clear
Set rngQuantityCells = Range("B120", Range("B120").End(xlDown))
For Each rngSinglecell In rngQuantityCells
If rngSinglecell.Value = "Primary" Then
Range("K" & Rows.Count).End(xlUp).Offset(1).Resize(rngSinglecell.Value, 14).Value = _
Range(Range("A" & rngSinglecell.Row), Range("D" & rngSinglecell.Row)).Value
ElseIf rngSinglecell.Value = "Backup" Then
Range("P" & Rows.Count).End(xlUp).Offset(1).Resize(rngSinglecell.Value, 19).Value = _
Range(Range("A" & rngSinglecell.Row), Range("D" & rngSinglecell.Row)).Value
End If
Next
End Sub
Try with Copy :
Public Sub CopyData()
Dim rngSinglecell As Range
Dim rngQuantityCells As Range
Dim intCount As Integer
Range("K2:S1400").Clear
Set rngQuantityCells = Range("B120", Range("B120").End(xlDown))
For Each rngSinglecell In rngQuantityCells
If rngSinglecell.Value = "Primary" Then
Range(Range("A" & rngSinglecell.Row), Range("D" & rngSinglecell.Row)).Copy Range("K" & Rows.Count).End(xlUp).Offset(1)
ElseIf rngSinglecell.Value = "Backup" Then
Range(Range("A" & rngSinglecell.Row), Range("D" & rngSinglecell.Row)).Copy Range("P" & Rows.Count).End(xlUp).Offset(1)
End If
Next
End Sub
No need to resize.
Well, among other things, you're using rngSingleCell.value in two completely different ways, and one of them isn't working.
rngSingleCell is the cell that contains Primary/Backup, correct? But you're trying to use that value in a resize method, which expects a numeric value. This is definitely going to throw you off.
Of course, without seeing the actual layout of your data it's hard to be sure, but it's not clear why you're using a method a method like Range().end(xlup).offset(1) to define your copying range; it's going to keep on copying the same data that way.
Related
I am working with a dataset that contains both numbers and names. In the dataset, some numbers and names are displayed and instead of manually going through thousands of rows I tried to make a script but it doesn´t happen anything.
Here is the code:
Sub MoveCells()
Dim row As Long
For row = 2 To LastRow
If Range("C" & row).Value Like "*0*" Then
Dim i As Integer
For i = 1 To 2
Range("C" & row).Insert Shift:=xlToRight
Next
End If
Next
End Sub
I am trying to move the cell that has a 0 in it, and the cell to the right of it, one step to right.
E.g. Cells C4 & D4 to D4 & E4.
I've made some adjustments to your code which will acheive the outcome you described.
Private Sub MoveCells()
Dim TargetRow As Long
Dim LastRow As Long
Dim ColumnCValue As Variant
Dim ColumnDValue As Variant
With Sheets("Sheet1")
LastRow = .Cells(.Rows.Count, 3).End(xlUp).row
End With
For TargetRow = 2 To LastRow
If Sheets("Sheet1").Range("C" & TargetRow).Value Like "*0*" Then
ColumnCValue = Sheets("Sheet1").Range("C" & TargetRow).Value
ColumnDValue = Sheets("Sheet1").Range("D" & TargetRow).Value
Sheets("Sheet1").Range("D" & TargetRow).Value = ColumnCValue
Sheets("Sheet1").Range("E" & TargetRow).Value = ColumnDValue
Sheets("Sheet1").Range("C" & TargetRow).ClearContents
End If
Next
End Sub
Now we first assign a value to for LastRow and when the If...Then statement is true, assign the values of Column C and Column D to the respective variables. Then, write those values 1 row to the right and finally clear the contents from Column C.
I wanted to convert below formula to VBA code.
=C1&"`"&K1&"`"&L1&"`"&J1
=VLOOKUP(M1,Data!$A:$J,9,)
=SUMPRODUCT(SUMIF(B1:B,B1,G1:G))
Currently i have enter this formula in 1st row and than copying this formula till the last row used which is taking lot time to apply formula because it has more than million row.
LR1 = Sheets("CRIMS").UsedRange.Rows.Count
Sheets("CRIMS").Range("M1:P1").AutoFill Destination:=Sheets("CRIMS").Range("M1:P" & LR1)
is there any way to convert this formula into VBA code?
For first formula the easiest way would be:
Range("M" & i).FormulaR1C1 = "=RC[-10]&""`""&K&""`""&L&""`""&J"
But for vlookup I prefer dictionaries/collections! It is much much faster.
If You have source data in Data sheet and You want to put that to CRIMS sheet to column M:
Sub vlookup()
Dim names As Range, values As Range
Dim lookupNames As Range, lookupValues As Range
Dim vlookupCol As Object
Dim lastRow As Long
Dim lastRow2 As Long
Dim objekt as Object
With Sheets("Data")
lastRow = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).row
Set names = Sheets("Data").Range("A1:A" & lastRow)
Set values = Sheets("Data").Range("I1:A" & lastRow)
End With
Set objekt = BuildLookupCollection(names, values)
With Sheets("CRIMS")
lastRow2 = 1000000
Set lookupNames = .Range("M1:M" & lastRow)
Set lookupValues = .Range("N1:N" & lastRow)
End With
VLookupValues lookupNames, lookupValues, objekt
Set objekt = Nothing
End Sub
Function BuildLookupCollection(categories As Range, values As Range)
Dim vlookupCol As Object, i As Long
Set vlookupCol = CreateObject("Scripting.Dictionary")
On Error Resume Next
For i = 1 To categories.Rows.Count
Call vlookupCol.Add(CStr(categories(i)), values(i))
Next i
On Error GoTo 0
Set BuildLookupCollection = vlookupCol
End Function
Sub VLookupValues(lookupCategory As Range, lookupValues As Range, vlookupCol As Object)
Dim i As Long, resArr() As Variant
ReDim resArr(lookupCategory.Rows.Count, 1)
For i = 1 To lookupCategory.Rows.Count
resArr(i - 1, 0) = vlookupCol.Item(CStr(lookupCategory(i)))
Next i
lookupValues = resArr
End Sub
Quotation Marks need to be doubled in VBA
Try this:
For i = 1 To LR1
Range("M" & i).Formula = "=C" & i & "&""`""&K" & i & "&""`""&L" & i & "&""`""&J" & i
Range("N" & i).Formula = "=VLOOKUP(M" & i & ",Data!$A:$J,9,)"
Next i
(replace column letters with actual target column)
As mentioned in the comments Looping in this case is highly inefficient.
Use this Code to insert the formulas all at once. It still takes some time for 1 Milion rows though.
Range("M1:M" & LR1).Formula = "=C:C & ""`"" & K:K & ""`"" & L:L & ""`"" & J:J"
Range("N1:N" & LR1).Formula = "=VLOOKUP(M:M,Data!$A:$J,9,)"
I have code that is not writing anything. I get a Match problem and a mismatch error in the code line below
rtar = Evaluate("=MATCH(" & ColLetter(rng1.Columns(2).Column) & rng1.Row & "&" & ColLetter(rng1.Columns(3).Column) & rng1.Row & "," & ColLetter(rng3.Columns(1).Column) & "1:" & ColLetter(rng3.Columns(1).Column) & last2 & "&" & ColLetter(rng3.Columns(3).Column) & "1:" & ColLetter(rng3.Columns(3).Column) & last2 & ",0)")
is highlighted in yellow.
To quickly explain the code and using my Excel image below the expected written result is the grey highlight in cells F8,G8,H8. The data that gets written into these cells only occurs when any set of numbers get written in the cell range, E6:E17 and only then. The data source is from cells M5 to O17. So as an example when cell E8 (3rd line down) has the 10-1 in it the code would search the data source (3rd line down) and write from the data source cells M8/N8/O8 to cells F8/G8/H8.
Please don’t suggest using a formula because in the arr1 and arr2 I will be using about 50 or more ranges. I only want to use this code and just need help with making the necessary offset and match adjustments.
Sub PlaceNumbers()
Dim c As Range, rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range
Dim last1 As Long, last2 As Long, rtar As Long, xtar As Long
Application.ScreenUpdating = False
With ActiveSheet
'create arrays
arr1 = Array(.Range("D5:H17"))
arr2 = Array(.Range("L5:O17)) '
'loop through arrays
For i = LBound(arr1) To UBound(arr1)
Set rng1 = arr1(i)
Set rng3 = arr2(i)
last1 = .Cells(.Rows.Count, ColLetter(rng1.Columns(1).Column)).End(xlUp).Row
last2 = .Cells(.Rows.Count, ColLetter(rng3.Columns(1).Column)).End(xlUp).Row
For Each c In rng1.Offset(1, 1).Resize(, 1)
If c <> "" Then
rtar = Evaluate("=MATCH(" & ColLetter(rng1.Columns(2).Column) & rng1.Row & "&" & ColLetter(rng1.Columns(3).Column) & rng1.Row & "," & ColLetter(rng3.Columns(1).Column) & "1:" & ColLetter(rng3.Columns(1).Column) & last2 & "&" & ColLetter(rng3.Columns(3).Column) & "1:" & ColLetter(rng3.Columns(3).Column) & last2 & ",0)")
xtar = Application.Match(c.Offset(0, -2), Range(ColLetter(rng3.Columns(1).Column) & rtar & ":" & ColLetter(rng3.Columns(1).Column) & last2), 0)
With Application.WorksheetFunction
c.Offset(0, 1) = .Index(Range(ColLetter(rng3.Columns(2).Column) & rtar & ":" & ColLetter(rng3.Columns(2).Column) & last2), xtar)
c.Offset(0, 2) = .Index(Range(ColLetter(rng3.Columns(3).Column) & rtar & ":" & ColLetter(rng3.Columns(3).Column) & last2), xtar)
c.Offset(0, 3) = .Index(Range(ColLetter(rng3.Columns(4).Column) & rtar & ":" & ColLetter(rng3.Columns(4).Column) & last2), xtar)
End With
End If
Next c
Next
End With
Application.ScreenUpdating = True
End Sub
Function ColLetter(Collet As Integer) As String
ColLetter = Split(Cells(1, Collet).Address, "$")(1)
End Function
Exec image
I think the existing answer (https://stackoverflow.com/a/55959955/8811778) is better (provided it does what you need it to) as it's shorter and easier to maintain/debug.
But I include an alternative, longer version below.
If the only logic/rule that results in values in M8:O8 being written to F8:H8 is "number of rows down" (i.e. 3 rows down), then I don't think you really need to use MATCH function.
If I understand correctly, you just want the Nth row of the source data, where N corresponds to the row of whatever non-empty cell (in the yellow cells) you're currently processing.
If you change your For each c in rng1.Offset(1, 1).Resize(, 1) to instead loop through the yellow cells one row at a time, you will have access to N (otherwise you need to do some row arithmetic: c.Row - first row of yellow cells + etc...).
Note that N is the variable rowIndexRelativeToRange in the code below and is relative to the range, not the worksheet (i.e. first row in the yellow cells, not first row of the worksheet).
Option Explicit
Sub PlaceNumbers()
Dim someSheet As Worksheet
Set someSheet = ActiveSheet ' Refer to this sheet by name if possible
With someSheet
Dim arr1 As Variant
arr1 = Array(.Range("D5:H17"))
Dim arr2 As Variant
arr2 = Array(.Range("L5:O17"))
End With
'Application.ScreenUpdating = False ' Uncomment when you think code is ready/working
Dim i As Long
Dim rng1 As Range, rng2 As Range
For i = LBound(arr1) To UBound(arr1)
Set rng1 = arr1(i)
Set rng2 = arr2(i)
' We have to resize the ranges (to get rid of the first row and first column)
' You may want to re-think whether the addresses you specify (when creating arr1 and arr2)
' even need to include the first row and first column (e.g. E6:H17 instead of D5:H17)
' -- or whether you could just ensure the address passed in already excludes the first row and first column.
' It depends on whether you need to use the first row and first column (somewhere else in your code).
' But precluding them (if possible) would shorten/simplify the procedure's logic.
Dim inputColumn As Range
Set inputColumn = rng1.Offset(1, 1).Resize(rng1.Rows.Count - 1, 1) ' -1 when resizing, otherwise you're looking at range E6:E18, not E6:E17
Dim dataSourceRange As Range
Set dataSourceRange = rng2.Offset(1, 1).Resize(rng2.Rows.Count - 1, rng2.Columns.Count - 1)
Dim rowIndexRelativeToRange As Long ' This index is 1-based and relative to the range, not the worksheet.
For rowIndexRelativeToRange = 1 To inputColumn.Rows.Count
If inputColumn(rowIndexRelativeToRange, 1) <> "" Then
inputColumn(rowIndexRelativeToRange, 1).Offset(0, 1).Resize(, 3).Value = dataSourceRange(rowIndexRelativeToRange, 1).Resize(, 3).Value
End If
Next rowIndexRelativeToRange
Next i
'Application.ScreenUpdating = True ' Uncomment when you think code is ready/working
End Sub
Putting this here because I don't want to put in a comment. Why can't you use a worksheet change event? You can set the target range to multiple ranges. Place this code in the worksheet containing the two areas you showed in your example. When the value in a cell changes it will automatically update the three cells to the right.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E6:E17")) Is Nothing Then
Range(Target.Address).Offset(, 1).Resize(1, 3).Value = Range(Target.Address).Offset(, 8).Resize(1, 3).Value
End If
End Sub
In my excel sheet I have the following code:
=IF(ISERROR(MATCH(D2,'Sheet 2'!A:A,0)),"",NOW())
This basically checks to see if the value in D2 matches any values in column A:A in sheet 2, and then populates the cell with a date and time with NOW().
My problem is the date and time is counting up because I am using the NOW() function whereas what I need is the date to, in a way, take a snapshot of the date or freeze the date. This table I am creating is acting like a log so I need the date to stay as it is when it is put into the cell.
Any help with this is much appreciated.
You could have this automatically run, if you paste it in the code behind your sheet (Where the range theCells is the column where the timestamps are going):
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("theCells")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Range(Target.Address).Value <> "" Then
Range(Target.Address).Copy
Range(Target.Address).PasteSpecial xlPasteVaues
End If
End Sub
Ok so I solved it, In my VBA I have the following code which pretty much creates a log file when my button is clicked, it takes various information in different cells and populates it in the next defined available row:
Sub copylog()
Dim LastRow As Long, ws As Worksheet
Dim wt As Worksheet
Set ws = Sheets("Create Log")
Set wt = Sheets("PDF Creation")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range("A" & LastRow).Value = wt.Range("N11").Value
ws.Range("B" & LastRow).Value = wt.Range("N12").Value
ws.Range("C" & LastRow).Value = wt.Range("N13").Value
ws.Range("D" & LastRow).Value = wt.Range("N14").Value
ws.Range("E" & LastRow).Value = wt.Range("N15").Value
ws.Range("F" & LastRow).Value = wt.Range("N16").Value
ws.Range("G" & LastRow).Value = wt.Range("AT19").Value
ws.Range("H" & LastRow).Value = wt.Range("AT21").Value
ws.Range("I" & LastRow).Value = wt.Range("AT23").Value
ws.Range("J" & LastRow).Value = wt.Range("AT25").Value
ws.Range("K" & LastRow).Value = wt.Range("AT27").Value
ws.Range("L" & LastRow).Value = wt.Range("A2").Value
ws.Range("M" & LastRow).Value = Environ("Username")
End Sub
The code above will populate a table in the next available row, for example, the first line:
ws.Range("A" & LastRow).Value = wt.Range("N11").Value
This will take the value that populates N11 in the PDF create sheet and populate the next available row in column A in the create log sheet (using copy and paste).
The line that has fixed my time problem is the line:
ws.Range("L" & LastRow).Value = wt.Range("A2").Value
In cell A2, I have the NOW() function and the button copies and pastes it into the next available space in column L (copies and pastes as TEXT).
I have the code that nicely calculates the average I want. But now I want it to only run the calculation if the referenced cells contain values. I am totally stumped on how to feed conditions into my code.
Dim i%
Dim rng As Range
Dim last&
last = Range("A65536").End(xlUp).Row
For i = 2 To last
Range("F" & i).FormulaR1C1 = _
"=AVERAGE(R[-4]C[-2],R[-2]C[-2],RC[-2],R[2]C[-2],R[5]C[-2],)"
Next i
End Sub
I tried working with AVERAGEIF, but I can't get it to work either. the range gives me a #Value in the range whenever I try to set it using the function wizard. So I have no idea how to make it work in VBA.
Any and all help would be appreciated.
*Edit - I only want the average line to appear in the cells, but I want to test the cells for values before doing the calculation. (Siddharth, thanks for your answer anyway!) To clarify:
Dim i%
Dim rng As Range
Dim last&
last = Range("A65536").End(xlUp).Row
For i = 2 To last
'test for all cells having values here
Range("F" & i).FormulaR1C1 = _
"=AVERAGE(R[-4]C[-2],R[-2]C[-2],RC[-2],R[2]C[-2],R[5]C[-2],)"
Next i
End Sub
***Edit 2: To be more clear as to what I'm looking for, I want something like this:
Dim i%
Dim last&
last = Range("A65536").End(xlUp).Row
For i = 2 To last
While Range("D" & i - 4).Value <> "" And Range("D" & i + 4).Value <> ""
Range("F" & i).FormulaR1C1 = _
"AVERAGE(R[-4]C[-2],R[-2]C[-2],RC[-2],R[2]C[-2],R[5]C[-2]))"
Wend
Next i
But my while statement is giving me trouble, as I keep getting an error when I reach that point in the code. I also have tried:
While Range("D" & i - 4 And "D" & i + 4).Value <> ""
Which gives me run time error 13: type mismatch.
If I understand you correctly then you need to check if the number of cells in a range equal the number of filled values. For example
Sub a()
Dim i%
Dim rng As Range
Dim last&
last = Range("A65536").End(xlUp).Row
For i = 2 To last
Range("F" & i).FormulaR1C1 = "=if(" & _
"Rows(R[-4]C[-2])+Rows(R[-2]C[-2])+Rows(RC[-2])+Rows(R[5]C[-2])<>" & _
"COUNTA(R[-4]C[-2],R[-2]C[-2],RC[-2],R[2]C[-2],R[5]C[-2],)-2,""Blank""," & _
"AVERAGE(R[-4]C[-2],R[-2]C[-2],RC[-2],R[2]C[-2],R[5]C[-2],))"
Next i
End Sub