I need to write a macro that compares the date in B1 with the date in columns D1.DB1. If they match, the column that matches needs to be copied and paste values. This is what I have done so far. But it is not working.
Sub MyCopyPasteValues()
' CopyPasteValus Macro
' Macro to hard code last weeks data.
Dim i As Integer
Sheets("data").Range("B1").Select
For i = 4 To 56
If Worksheets("Data").Cells(1, i).Value = "B1" Then
Range(1, i).Select
ActiveCell.EntireColumn.Select
Selection.Copy
ActiveSheet.PasteSpecial xlPasteValues
End If
Next i
End Sub
Okay, so first of all: avoid using .Select method, it is very risky and can harm your data.
You do not need to select cell if you want to do something with it. Also if you want to compare one cell value with another, you should use Range() or Cells(). You used "B1" which means you were checking for value B1 not for value of Cell B1.
Edit:
Not sure if this is what you want so lets give it a try. y represents row number and i represents column number. For each y there will checked all cells in columns i. They will be checked with a date in row y in column B.
Sub MyCopyPasteValues()
' CopyPasteValus Macro
' Macro to hard code last weeks data.
Dim i As Byte, ws As Worksheet
Set ws = Worksheets("Data")
For y = 3 To 73
For i = 4 To 56
If ws.Cells(y, i).Value = ws.Range("B" & y).Value Then
ws.Cells(y, i).Value = ws.Cells(y, i).Value
End If
Next i
Next y
End Sub
Sub MyCopyPasteValues()
' CopyPasteValus Macro
' Macro to hard code last weeks data.
Dim i As Byte, ws As Worksheet
Set ws = Worksheets("Data")
For y = 3 To 73
For i = 4 To 56
If ws.Cells(1, i).Value = ws.Range("B" & 1).Value Then
ws.Cells(y, i).Value = ws.Cells(y, i).Value
End If
Next i
Next y
End Sub
Related
[Copy A2 to E2 till the end of row of the table and check if the cell is within the same month](https://i.stack.imgur.com/Q7YAx.png)
Hi,
I would like to loop through rows from a sheet table from column A2 to E2 to A3 to E3... till the end of the table Ai to Ei by defining a variable and counting the last row of the table.
As the second step, I would like to copy the cells into another sheet and fill it the corresponding months.
[Desired Output--> it will copy the data and return to another sheet in the corresponding month] (https://i.stack.imgur.com/zhgYh.png)
Instead, I've changed the data type into a number format and have set up two condition to loop through.
eg. 1/1/2017 change to 42736
28/2/2017 change to 42794
Sub Mike_Copy_cell()
Dim i As Long 'for looping inside each cell
Dim myvalue As Variant
Dim Lastrow As Long
Const StartRow As Byte = 2
Dim LastMonth As Long
("Mike Filter").Select
Lastrow = Range("A" & StartRow).End(xlDown).Row
For i = StartRow To Lastrow
myvalue = Range("H" & i).Value
If myvalue \< Sheets("Automate Report").Range("A" & i).Value \_
'First data Feb Data 42794 \< Jan Category 42736
Then Sheets("Automate Report").Range("B" & i).Value = ""
'leave the cells in blanks and loop through next cell
If myvalue > Sheets("Automate Report").Range("A" & i).Value _
'First data Feb Data 42794 > Jan Category 42736
Then Range("A" & i, "E" & i).Copy Sheets("Automate Report").Range("B" & i, "F" & i)
'Copy the cells into corresponding category
Next i
End sub()
In my output, it is able to loop through and copy all the cells. However, I am wondering the reason why VBA output is not able leave any blank cells when the first condition is met ?
**I am expecting some blanks in the table if it is not data is not within the same month or in my case is less than criteria I have set. **
The output of my code
If myvalue < Sheets("Automate Report").Range("A" & i).Value _
Then Sheets("Automate Report").Range("B" & i).Value = ""
Greatly appreciate if you can advise the flaws in my code. Massive Thanks.
Best regards,
Kenneth
I'll try to help. But before, may I give you two suggestions that might help you?
First, for me the best way to find the last row is, instead of using xldown from the first row, using xlup from the very last row of excel. This way, if there is a blank in any middle row, the code still gives you the last row with value.
Second, I found that referring to any cells with the "range" method may limit you sometimes when using variables in this reference. I think using the "cells(row, column)" method is more useful.
Why not trying this?
Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Sorry for the suggestions, It's just that I wish someone had taught them to me sooner.
Back to the topic, I think the problem is how you structure the "if" statement. Allow me to change it a bit:
Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = StartRow To Lastrow
myvalue = cells(i, 8).Value
'if myvalue date is equal or previous to the one found in Ai...
If myvalue <= Sheets("Automate Report").cells(i, 1).Value then
Sheets("Automate Report").cells(i, 2).Value = ""
'but if myvalue is later than Ai...
else
sheets("Automate Report").select
range(cells(i, 1), cells(i, 5).select
selection.copy
cells(i, 2).select
activesheet.paste
end if
Next i
Hope this helps. Best regards,
Mike
I'm not sure what your code is doing but consider using an array(12) of row numbers, one for each month. Copy lines into corresponding month and increment the row number for that month. For example ;
Option Explicit
Sub Mike_Copy_cell()
Const LINES_MTH = 5 ' lines per month
Dim wb As Workbook
Dim wsIn As Worksheet, wsOut As Worksheet
Dim lastrow As Long, rIn As Long, rOut(12) As Long
Dim uid As String, prevuid As String
Dim dAVD As Date, m As Long, n As Long
Set wb = ThisWorkbook
Set wsIn = wb.Sheets("Mike Filter")
Set wsOut = wb.Sheets("Automate Report")
' space out months
For n = 0 To 11
rOut(n + 1) = 2 + n * LINES_MTH
wsOut.Cells(rOut(n + 1), "A").Value2 = MonthName(n + 1)
Next
n = 0
With wsIn
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For rIn = 2 To lastrow
dAVD = .Cells(rIn, "D")
' create a unique ID to skip duplicates
uid = .Cells(rIn, "A") & Format(.Cells(rIn, "D"), "YYYY-MM-DD")
If uid <> prevuid Then
m = Month(dAVD)
.Cells(rIn, "A").Resize(, 5).Copy wsOut.Cells(rOut(m), "B")
rOut(m) = rOut(m) + 1
n = n + 1
End If
prevuid = uid
Next
End With
MsgBox n & " lines copied to " & wsOut.Name, vbInformation
End Sub
If cell in column I1-I14 is greater than cell in column J1-J14, I want to cut the entire row and paste values to the first empty row. (From row 16 and down.)
If cell i is greater than cell j, cut row and paste values to first empty row (row 16 in this example)
This code just pastes in the first row:
Sub Knapp6_Klicka()
Dim i As Long
Dim j As Long
j = 1
For i = 3 To 500
If Cells(i, 9).Value > Cells(i, 10).Value Then
Cells(i, 12).EntireRow.Cut Sheets("Blad1").Range("A" & j)
j = j + 1
End If
Next i
End Sub
I tried to combine the paste with two different solutions.
One like this, where I recorded a macro and went to the last cell, then up to the first empty cell:
Range("A1048576").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
And one solution that I found on an Excel community:
Sub compareresult()
Dim row1 As Integer
Dim row2 As Integer
row2 = 1
For row1 = 8 To 500
If sheet1.Cells(row1, 11).value > sheet1.Cells(row1, 9).value Then
sheet1.Cells(row1, 1).EntireRow.Copy Sheets(11).Cells(row2, 1)
row2 = row2 + 1
End If
Next row1
End Sub
If cell in column I1-I14 is greater than cell in column J1-J14, i want to cut entire row and paste values to the first empty row. (From row 16 and down)
Here is a method which doesn't cut and paste in a loop. Since you are not deleting the row or "cutting and inserting" the row, here is a simple approach. The below code follows a basic logic
Logic
Loop and identify the range.
If found, then copy the range in 1 go.
Finally clear the range which was copied (if copied).
Code
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rngToCopy As Range
Dim i As Long
'~~> Change this to relevant sheet
Set ws = Sheet1
With ws
'~~> Loop and identify the range
For i = 2 To 14
If .Range("I" & i).Value2 > .Range("J" & i).Value2 Then
If rngToCopy Is Nothing Then
Set rngToCopy = .Rows(i)
Else
Set rngToCopy = Union(rngToCopy, .Rows(i))
End If
End If
Next i
'~~> If found then copy and clear
If Not rngToCopy Is Nothing Then
rngToCopy.Copy .Rows(16)
rngToCopy.Clear
End If
End With
End Sub
EDIT:
To incorporate new edits
Works perfectly! Thanks! :) I failed to fully describe my problem.. What i also need is to paste it as special (only paste the value and not the formulas). Do you got any quick solution for that? – Johl 5 hours ago
Replace
rngToCopy.Copy .Rows(16)
to
rngToCopy.Copy
DoEvents
.Rows(16).PasteSpecial Paste:=xlPasteValues
Have a try with this.
It's based on the range you gave. Skipped over row 1 since you have headers in it.
Dim i As Long, lRow As Long, ws As Worksheet
Set ws = Sheets("Blad1") 'Your sheet name
lRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1 'Finding the last row
If lRow < 16 Then lRow = 16 'The starting row you want to cut to
For i = 2 To 14 'Your range of rows to check
If ws.Range("I" & i) > ws.Range("J" & i) Then
ws.Range("I" & i).EntireRow.Cut ws.Range("A" & lRow) 'Cutting the whole row so you use column A to cut to
lRow = lRow + 1 'Move down 1 row for where to cut to
End If
Next i
Edit:
Because you only want the values to copy accross we can't use Cut and PasteSpecial xlValues so instead we will duplicate the value of the entire row to the new location, then clear the row (filling in for the cutting part). If clear is too much we can just ClearContents to remove the values in the cells instead of the formatting if that happens. Make sure to always save before running VBA code for the first time.
Dim i As Long, lRow As Long, ws As Worksheet
Set ws = Sheets("Blad1") 'Your sheet name
lRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1 'Finding the last row
If lRow < 16 Then lRow = 16 'The starting row you want to cut to
For i = 2 To 14 'Your range of rows to check
If ws.Range("I" & i) > ws.Range("J" & i) Then
ws.Range("A" & lRow).EntireRow.Value = ws.Range("I" & i).EntireRow.Value 'Copying the values over
ws.Range("I" & i).EntireRow.Clear 'Clear the row
lRow = lRow + 1 'Move down 1 row for where to cut to
End If
Next i
Your code is doomed to failure because you do not take into consideration that you are cutting the found row. Think about what that means. Your row with the In,Out is row 15 and you wish to paste to row 16. If you cut row 5 (for example) then rows 15 and 16 will become rows 14 and 15. It also means that your next row (which you think will be row 6) will actually be what was row 7 before the cut.
How can I cycle through sheet1 to see if there is data in that cell?
If there is no data then go to the next cell.
If there is data in the next cell paste it into sheet2.
The criteria are:
I cannot use a set range it will change as the data changes in sheet1.
I can keep sheet names a constant such as sheet1 and sheet2.
I found a way using columns and or rows yet that code has a major issue. If there is no starting data in the first cell it will not copy anything in the entire row and or column.
I am posting the code I worked with to check the data in columns but if there is no starting data it will skip the whole row.
Sub CopytoImport()
Dim wb As Workbook
Dim iCol As Long
Dim ws As Worksheet
Sheets("sheet2").Cells.ClearContents
' Loop through the column
For iCol = 1 To 22 ' Call out columns I cannot set this every time it should look threw all cells
With Worksheets("sheet1").Columns(iCol)
' Check tht column is not empty
If .Cells(1, 1).Value = "" Then
'Nothing in this column
'Do nothing
Else
' Copy the coumn to te destination
Range(.Cells(1, 1), .End(xlDown)).Copy _
Destination:=Worksheets("sheet2").Columns(iCol).Cells(1, 1)
End If
End With
Next iCol
ActiveWorkbook.Save
End Sub
Function runcode()
Call CopytoImport
End Function
Cells(1, 1) is just RANGE.("A1") you are only operating on this cell in your code. You would need Cells(1, iCol) to account for what column you are on during your loop.
You might also need a nested loop since you are looping through rows as well. The basic outline of a nested loop is as follows. Note the Cells(1,1) is replaced with the i and j representing what row and what column we are on. This might not be the fastest way to achieve the results you want but it sounds like this is what you are asking for help with. You will also need to define a lastrow (with a + 1 at the end to get the next blank cell) in your Sheet2 for when you paste the data. You would put this right under where the loop starts going through rows. This is so the lastrow of your sheet2 is recalculated each time data is being moved to that sheet. I am not going to re-write your code since you stated it is not complete but here is an example that should help you.
For j = 5 To lastcolumn
For i = 5 To lastrow
Dim lastrow2 As Long
lastrow2 = Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1
If Worksheets(2).Cells(i, j).Value <> 0 Then
Worksheets(1).Range("C" & lastrow2).Value = Worksheets(2).Cells(i, j).Value
Worksheets(1).Range("B" & lastrow2).Value = Worksheets(2).Cells(2, j).Value
End If
Next i
Next j
To find your lastrow:
dim lastrow as long
lastrow = Range("A" & rows.count).End(xlup).Row ' or whatever column contains the data
To find your last column
Dim lastcolumn As Long
lastcolumn = Worksheets(2).Cells(2, Columns.Count).End(xlToLeft).Column
We have a single formula which we are coping to over to a defined range of over 250'000 cells. The performance of Excel clearly takes a hit. Is there a way to improve the performance by using VBA?
The formula returns either 0 or 1 as a value to the cell depending on 4 criteria. The Excel formula is:
=IF(NOT(ISTEXT($B9)),"",IF((L$5=""),"",IF(AND(M$5>MIN($G9,$H9),L$5<MAX($G9,$H9)),1,0)))
Thanks for your help !
Something like this could be an alternative to 250,000 rows of formulas. As stated in the comments, this still would take some time given the size of the data set. I ran a test with a sheet that just had the necessary cells populated with 249,488 rows and the code took 12 seconds to run. With more data in the sheet I anticipate it taking longer than that.
That said this will reduce the memory of your file significantly since there won't be any formulas:
Sub Run()
Dim i As Long 'Row number for loop
Dim lRow As Long 'Last row of data set
Dim ms As Worksheet
Set ms = Sheets("Sheet1") 'Change to whatever sheet you need this in
With ms
If .Cells(5, 12).Value = "" Then
MsgBox "Please enter a value in Cell L5 before proceeding."
Else
lRow = .Cells(.Rows.Count, 2).End(xlUp).Row 'This is assuming Column B is populated in full to the bottom of the data set
For i = 9 To lRow 'This is assuming you will be starting the calculation in row 9
If IsNumeric(.Cells(i, 2).Value) = False And .Cells(i, 2).Value <> "" Then 'Ensuring Column B is text and not blank
If .Cells(5, 12).Value < WorksheetFunction.Max(.Cells(i, 7).Value, .Cells(i, 8).Value) And .Cells(5, 13).Value > WorksheetFunction.Min(.Cells(i, 7).Value, .Cells(i, 8).Value) Then
.Cells(i, 1).Value = 1 'Assuming you want the 0 or 1 in Column A
Else
.Cells(i, 1).Value = 0 'Assuming you want the 0 or 1 in Column A
End If
End If
Next i
End If
End With
End Sub
EDIT
Per Cornintern's awesome suggestion, I've rewritten this to use arrays instead of looping through the entire range. This now takes less than 2 seconds:
Sub Run()
Dim i As Long 'Row number for loop
Dim lRow As Long 'Last row of data set
Dim ms As Worksheet
Dim mVar1() As Variant
Dim mVar2() As Variant
Dim mVar3() As Variant
Dim rVar() As Variant
Dim num1 As Long
Dim num2 As Long
Set ms = Sheets("Sheet1") 'Change to whatever sheet you need this in
With ms
If .Cells(5, 12).Value = "" Then
MsgBox "Please enter a value in Cell L5 before proceeding."
Else
lRow = .Cells(.Rows.Count, 2).End(xlUp).Row 'This is assuming Column B is populated in full to the bottom of the data set
ReDim rVar(1 To lRow - 8) As Variant
mVar1 = .Range("G9:G" & lRow)
mVar2 = .Range("H9:H" & lRow)
mVar3 = .Range("B9:B" & lRow)
num1 = .Cells(5, 12).Value
num2 = .Cells(5, 13).Value
For i = 1 To UBound(mVar1) 'This is assuming you will be starting the calculation in row 9
If IsNumeric(mVar3(i, 1)) = False And mVar3(i, 1) <> "" Then 'Ensuring Column B is text and not blank
If num1 < WorksheetFunction.Max(mVar1(i, 1), mVar2(i, 1)) And num2 > WorksheetFunction.Min(mVar1(i, 1), mVar2(i, 1)) Then
rVar(i) = 1
Else
rVar(i) = 0
End If
End If
Next i
End If
End With
Range("A9:A" & lRow) = WorksheetFunction.Transpose(rVar)
End Sub
Given that your formula is simple I would expect that the formula approach would calculate faster/better than VBA:
Excel calculates using multiple cores: VBA only uses 1
The overhead of transferring data to VBA and back to Excel is
substantial
Excel can calculate over a million simple formulas per second
Excel can automatically recalculate efficiently if any of the data
changes, but you would have to rerun the entire VBA sub.
I would recommend seeing how long the formula approach takes in practice: I would be surprised if it calculates in more than a second.
Okay folks, I have this simple table below and I am trying to calculate a macro vba formula in column G as long as column c has a value. All the info in the spreadsheet is already pulled in from a previous macro. Here is what I have....
Sub Macro1()
'
' Macro1 Macro
'
Dim x As Long
x = CLng((d2 + e2) / c2)
For Each r In Intersect(ActiveSheet.UsedRange, Range("C:C"))
If r.Value <> "" Then
r.Offset(1, 5).Value = x
End If
Next r
End Sub
Try the code below, it will loop through Column C (until last row with value in it), and will calculate your formula with the relevant parameters of that row in Column G.
Note: your formula of (D+E)/C will give you small values, as C has high values. If that's the formula you want to use, than you need to change the output from Long to Double to show the numbers after the 0..
Code
Option Explicit
Sub Macro1()
' Macro1
Dim r As Range
Dim LastRow As Long
' modify "Sheet1" to your sheet's name
With Sheets("Sheet1")
' find last row with data in Column C ("Salary")
LastRow = .Cells(.rows.Count, "C").End(xlUp).Row
For Each r In .Range("C2:C" & LastRow)
If r.Value <> "" Then
r.Offset(0, 4).Value = CDbl((Range("D" & r.Row).Value + Range("E" & r.Row).Value) / r.Value)
End If
Next r
End With
End Sub
Try this:
Range("G2:G" & Range("C" & Rows.Count).End(xlUp).Row).Formula = "=CONCATENATE(C2,"", "",B2)"
Counts rows in column C, if not empty, fills in Concatenation formula that you can change to your formula.
You refer to cells as Range("D2") etc rather than just d2.