I'm trying to use vba to automate a simple process by getting a data from another sheet in the same workbook. I'm cannot just copy because the data is updated dynamically, if there is changes to the other sheet, it will be affected.
ActiveCell.FormulaR1C1 = "='Sheet2'!R[7]C[4]"
This is my first time doing vba and I think the R[7]C[4] meant sort of the coordinates of getting the value either vertically or horizontally based on the positivity and negativity of the numbers.
Sheet1
2-Jul
-------
item1 item2 3
item1.1 item2.2 43
total 46
3-Jul
-------
item1 item2 3
item1.1 item2.2 41
total 44
Sheet2
1-Jul
2-Jul 46 (works here)
3-Jul 44 (does not work here)
It will run through the dates on sheet 2 and show the total accordingly on the 2nd column. This is what I did.
For Each cell In Range("A1:A3")
If cell.Value = selDate Then
Range("B" & cell.row).Select
ActiveCell.FormulaR1C1 = "='Sheet1'!R[3]C[3]"
End If
Next cell
I place my selected cell on 2-Jul and it got the cell correct and took 46 but as for the second one that I ran by placing my selected cell on 3-Jul, it took data just one cell down from 46 than actually getting 44.
I'm going to go out on a limb as I suspect that your use of offset R1C1 formulas was due to some problems coming up with an adequate formula for retrieving the 'Total' from Sheet1 for each date on Sheet2.
Sub get_dated_total()
Dim rw As Long, ws1 As Worksheet, sFormulaR1C1 As String
sFormulaR1C1 = "=IFERROR(INDEX(INDEX(Sheet1!C3,MATCH(RC1,Sheet1!C1,0)):INDEX(Sheet1!C3,ROWS(C3)),MATCH(""total"",INDEX(Sheet1!C,MATCH(RC1,Sheet1!C1,0)):INDEX(Sheet1!C,ROWS(C)), 0)), """")"
Set ws1 = Worksheets("Sheet1")
With Worksheets("Sheet2")
For rw = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
If IsDate(.Cells(rw, 1)) Then
If CBool(Application.CountIf(ws1.Columns(1), .Cells(rw, 1).Value)) Then
.Cells(rw, 2).FormulaR1C1 = sFormulaR1C1
End If
End If
Next rw
End With
Set ws1 = Nothing
End Sub
Well, might not be the best solution but I guess the latter ActiveCell.row refers to Sheet2 if I'm on Sheet2 Selection. Now I have to store a temp row number instead at the start to get the true ActiveCell.row which is the row of 2-Jul
Dim tmpRow As Integer
tmpRow = ActiveCell.Row
Then I'm gonna call it later
ActiveCell.Formula = "='Sheet1'!C" & tmpRow + 3
Related
I have a table with values based on monthly based and product in 1st column as shown below (Say "sheet1"). This table has conditional formatting applied to highlight cell colors red/yellow/green based on target. So, I want to take only specific month(current month- May) column and want VBA to check, if any cell in that column is Red, select that entire row and copy past it into another sheet for example "Sheet2" with headers.
Product = Target Feb Mar Apr May
Wood >= 5 10 10 10 10
wood >= 5 28 28 28 28
Tree >= 12 30 45 60 68
plastic >= 45 50 50 50 50
tree >= 50 50 50 50 50
iron >= 100 64 75 75 80
The values will change monthly and even sometimes target, so the coloring can be totally green/yellow/red sometimes. So, I want to automate this process using VBA, to go and check on "Sheet1" every month and pull any rows which has red cell highlighted for that month. OR even a button function could also help, so I can assign this macro to a button, this action should be done by clicking the button. Even it should also clear all rows from earlier month in Sheet2, which might have highlighted in last month but not in this month.
I tried, different ways to do this, its not recognizing the cell color. When I use the random/regular cell out of table and fill with red color and use find(ctrl+f) popup box to highlight using color format, it is working but its not taking the cells which has conditional formatting in a table. So, I don't know if there is a way to identify all the cells in the table which is highlighted in red using VBA.
INPUT (IN WORKSHEET1):
OUTPUT (IN WORKSHEET2):
Sub newnew()
declaring the worksheets, Sheet2 and Sheet3 should be changed to match your sheet names
Dim ws As Worksheet
Set ws = Sheets("Sheet2")
Dim wsTwo As Worksheet
Set wsTwo = Sheets("Sheet3")
clearing out previous data in wsTwo
wsTwo.Cells.Clear
finding the last row and column for ws with data inside
Dim lastRow As Integer
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim lastColumn As Integer
lastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
we are setting up the header here
ws.Range("A1:F1").Copy
wsTwo.Range("A1:F1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
beginning our loop from the last row and moving upwards till we hit row 2. We are checking if rowNum and lastColumn display format interior color is red. If it is we are taking that range, copying it, then pasting it in wsTwo. Note that we have that rowCounter which we set before entering the for loop. we will use that as a placeholder, incrementing every time that we paste in ws two, so that we don't paste over data we just pasted.
Dim rowCounterWsTwo As Integer
rowCounterWsTwo = 2
For rowNum = lastRow To 2 Step -1
If Cells(rowNum, lastColumn).DisplayFormat.Interior.Color = vbRed = vbRed Then
ws.Range(Cells(rowNum, 1), Cells(rowNum, lastColumn)).Copy
wsTwo.Range("A2:F2").Insert
Application.CutCopyMode = False
rowCounterWsTwo = rowCounterWsTwo + 1
End If
Next rowNum
End Sub
I have a workbook with 2 sheets that contain some of the same data. The first column in both worksheets contain a number assigned to an item, but sheet 2 contains more items
than sheet 1. Sheet 1 contains the items pertinent to me, so I am trying to copy the relevant data from sheet 2 into sheet 1.
For example:
Sheet 1
Column A
20
53
120
500
1123
etc
Sheet 2
Column A
1
2
3
4
5
etc
If the number in column A matches for both spreadsheets, I need to copy cell M from sheet 2 to cell I in sheet 1. I have tried a few different solutions posted elsewhere, but
since my data isn't ideally sorted between the two sheets, using things like VLookup wasn't working well.
I believe I need to store the information in column A in both sheets to an array and compare the data from there, I just have no clue how to write the code to continue
comparing the cell from sheet 1 until it finds a match in sheet 2, and then copy the data over.
Any help I can get would be greatly appreciated. Thanks everyone.
My current code:
Sub CopyFromSheet2()
Dim i As Long
Dim j As Long
Dim Range1 As Range
Dim Range2 As Range
Set Range1 = Sheets("Sheet1").Range("A:A")
Set Range2 = Sheets("Sheet2").Range("A:A")
For j = 1 To Range1
For I = 1 To Range2
If Sheets("Sheet1").Cells(i, "A").Value = Sheets("Sheet2").Cells(j, "A").Value Then
Sheets("Sheet1").Cells(i,"I").Value = Sheets("Sheet2").Cells(j, "M").Value
End If
Next i
Next j
End Sub
I am currently getting run time error 13 on the For j = 1 to Range1 line "Type mismatch"
Something to start with would be a loop from row 1 to last row in sheet 1, then for each of these rows, compare value of cell 1 to each value in sheet 2.
A way to compare them to each other would be like this:
If Sheets("sheet 1").Cells(i, "A").Value = Sheets("sheet 2").Cells(j, "A").Value Then
now you just need to put a nested loop around this and you are good to go.
To copy column m to i:
Sheets("sheet 1").Cells(i, "I").Value = Sheets("sheet 2").Cells(j, "M").Value
Now try out something and feel free to ask again if you are running into an error
So I ended up consolidating the columns I need into 1 spreadsheet to make things easier, and I found this question on SO: Comparing two columns, and returning a specific adjacent cell in Excel which was very similar to what I was trying to do. The formula
=IFERROR(VLOOKUP(C1, A:B, 2, 0), "")
worked perfectly for me, so I am using that instead of the VBA scrip.
http://i.stack.imgur.com/93bt7.png
Hi,
I am trying to work with a code I have made but am having some trouble.
If you look at my photo above, in cell B3 I have a CUSIP. What I want to do is copy that CUSIP and paste it in each row of info for that CUSIP (so rows A4 till A8). Then I want to move to the second CUSIP in J3 (the CUSIPS are all in row 3 and 8 columns apart) and then paste the CUSIP in rows J4 to J35.
I want to keep doing this over and over for 1000 securities but the issue is that the rows differ in length.
My code is working until I get to the last piece of code which I have put in as a comment. It works but is static. Only works for moving from the 1st to 2nd security then fails. I am trying to think of a dynamic way for me to move from the cell which the CUSIP is last pasted in to the third row and corresponding column everytime (column will be 9 apart every time from the last pasted cell).
Here it is:
Sub CUSIP_Copy_Paste()
Dim LastRow As Long
Dim LastCol As Long
Dim c As Long
Dim r As Long
Range("B3").Select
LastCol = Cells(4, Columns.Count).End(xlToLeft).column
For c = 2 To LastCol Step 8
LastRow = Cells(Rows.Count, c).End(xlUp).row
ActiveCell.Copy
Cells(4, ActiveCell.Offset(1, -1).column).PasteSpecial xlPasteValues
For r = 5 To LastRow
Cells(r, ActiveCell.Offset(1, 0).column).PasteSpecial xlPasteValues
Next r
''''''ActiveCell.Offset(-5, 9).Select
Next c
End Sub
Thanks!
Your error lies in the final offset. Instead of -5, put in a variable, preferrably the variable which is the difference between the end of the rows count and the beginning, which is always 3.
That is to say, Offset(3 - lastRow, 9)
You almost had it friendo :)
At the moment I’m only able to copy&paste stuff from one row.
I use the code below:
Dim lastRow As Long
With Sheets("Tab1")
If Application.WorksheetFunction.CountA(.Columns(3)) <> 0 Then
lastRow = .Cells(Rows.Count, "C").End(xlUp).Row + 1
Else
lastRow = 1
End If
Sheets("Tabelle2").Range("B85:S85").copy
.Range("C" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
My problem is that I need to copy and paste lists. Can someone show me how to use this code to copy&paste lists?
I wanted to copy more rows, like (A25:S25, A27:S27, A30:S30)
It should copy always the same rows.
There are two reasons for your code copying just one row:
The code selects just one row to copy
Sheets("Tabelle2").Range("B85:S85").Copy
The select just on row to Paste
.Range("C" & lastRow).PasteSpecial Paste:=xlPasteValues …
As it’s not clear if you want to copy several rows despite selecting just one or to copy that one row to several rows I’ll cover both options in order to give you an idea of what to do in both cases:
Setting the range to be copied
a. To copy just range B85:S85 one row only then what you are doing is correct
Wbk.Sheets("Tabelle2").Range("B85:S85")
b. To copy X rows down from row 85 (including row 85)
Wbk.Sheets("Tabelle2").Range("B85:S85").Resize(X)
c. To copy Y rows up from row 85 (including row 85)
Wbk.Sheets("Tabelle2").Range("B85:S85").Offset(1-Y, 0).Resize(Y)
d. To copy the range bounded by any combination of blank rows and blank columns in which "B85:S85" is included (see Range.CurrentRegion Property (Excel))
Wbk.Sheets("Tabelle2").Range("B85:S85").CurrentRegion
Note that this will include also any rows above and below row 85 if they have at least one cell not blank that causes the "current region" to extend upwards or downwards and it will also include any columns to the left of columns B or to the right of column S if they have at least one cell not blank that causes the "current region" to extend sideways
This procedure demonstrates the options explained above:
Sub Range_Set()
Dim rSrc As Range
With ThisWorkbook.Sheets("Tabelle2")
'If want to copy just this row 85
Application.Goto .Cells(1), 1
Set rSrc = .Range("B85:S85")
rSrc.Select: Stop
'If want to copy 5 rows down from row 85 (including row 85)
Application.Goto .Cells(1), 1
Set rSrc = .Range("B85:S85").Resize(5)
rSrc.Select: Stop
'If want to copy 5 rows up from row 85 (including row 85)
Application.Goto .Cells(1), 1
Set rSrc = .Range("B85:S85").Offset(-4, 0).Resize(5)
rSrc.Select: Stop
'If want to copy then range bounded by any combination of blank rows and blank columns in which "B85:S85" is included
'This will include also any rows above and below row 85 if they have at least one cell not blank that causes the "current region" to extend upwards or downwards
'Also will include also any columns to the left of columns B or to the right of column S if they have at least one cell not blank that causes the "current region" to extend sideways
Application.Goto .Cells(1), 1
Set rSrc = .Range("B85:S85").CurrentRegion
rSrc.Select: Stop
End With
End Sub
Setting the range where the copy takes place
To copy the source range as it is, then just need to select the first cell of your target range and the paste.special will cover paste the target to all cells required as per the size all target cell. However is you want to copy range B85:S85’ to several cell then you need to select the target rows. For example if we want to copyB85:S85’ over five rows starting at C5 then we need to set the target range as
.Range("C12").Resize(5).PasteSpecial Paste:=xlPasteValues
As we are going to copy only the values of the source, I suggest to use the Range.Value property of the Range object instead of the Copy…Paste method. One advantage of using this property is to avoid the use of the Clipboard.
Try this code (select\adjust the options as per your requirements)
Sub Range_Value()
Dim Wbk As Workbook
Dim lastRow As Long
Dim rSrc As Range
Rem Declare Objects
Set Wbk = ThisWorkbook 'use this if procedure is resident in the wbk with the tables
'Set Wbk = Workbooks(WbkName) 'use this if procedure is not resident in the wbk with the tables - update wbk name
With Wbk.Sheets("Tab1")
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Rem Set Copy Range
'since we are going to paste only values then we can save us from using the clippboard
'Sheets("Tabelle2").Range("B85:S85").Copy
'instaed create a range to replace the values of the target range with the values of this range
'Uncomment\Update the option needed according to you requirements
'for this test I'm using option b
'a. To copy just row 85
'Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85")
'b. To copy X rows down from row 85 (including row 85) X=5
Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85").Resize(5)
'c. To copy 5 rows up from row 85 (including row 85) Y=5
'Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85").Offset(-4, 0).Resize(5)
'd. To copy the range bounded by any combination of blank rows and blank columns in which "B85:S85" is included
'This will include also any rows above and below row 85 if they have at least one cell not blank that causes the "current region" to extend upwards or downwards
'Also will include also any columns to the left of columns B or to the right of column S if they have at least one cell not blank that causes the "current region" to extend sideways
'Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85").CurrentRegion
' As mentioned before we won't use the clipboard
'instead we replace the values with the values of the target range created earlier
'however we need to extend the range to the same size of the source range
.Range("C" & lastRow + 1).Resize(rSrc.Rows.Count, rSrc.Columns.Count).Value = rSrc.Value2
End With
End Sub
Hope this is clear enough and helps you to make progress with you coding, nevertheless let me know of any questions you might have.
I'm not quite sure what you're looking for - but here' how to loop:
Sub test()
For i = 25 to 30
Range(Cells(i,1),Cells(i,19)).Copy
Range(Cells(i,20),Cells(i,39)).PasteSpecial xlPasteValues
Next i
End Sub
That copies A25:S25 and pastes to T25:AM25...Then A26:S26, pastes T26:AM26, etc. until row 31.
Well now that the requirements are disclosed, we have the opportunity to apply another method. Bear in mind that the fact that the source range contains multiple areas may give us the idea of series of repetitive "copy paste values" which makes the undesirable use of the clipboard, or a repetitive Range Values.
This time instead of setting the source range as an object (which still can be done) we'll use an Array variable to grab the values of the multi-areas range
to later enter them in the target range as a unified and continuous range in one step.
This procedure sets an array with the values of the source range areas and then sets the values of the array to the target range using the Range.Value property.
Sub Range_MultiAreas_CopyValue()
Const kRowIni As Long = 25
Dim Wbk As Workbook
Dim aRngSrc() As Variant
Dim lRowLst As Long, l As Long, b As Byte
Rem Declare Objects
Set Wbk = ThisWorkbook
Rem Set Array with rows to copy as value
With Wbk.Sheets("Tabelle2")
l = kRowIni
For b = 1 To 30
If .Range("V" & l).Value2 = 0 Then
Rem Resize Array
On Error Resume Next
ReDim Preserve aRngSrc(1 + UBound(aRngSrc))
If Err.Number <> 0 Then ReDim Preserve aRngSrc(1)
On Error GoTo 0
Rem Set Row Values In Array
aRngSrc(UBound(aRngSrc)) = .Cells(l, 2).Resize(, 16).Value2
Rem Increase Row Pointer
l = l + 2
End If: Next: End With
Rem Reset Arrays Structure
With WorksheetFunction
aRngSrc = .Transpose(.Transpose(aRngSrc))
End With
Rem Let Array Values in Target Range
With Wbk.Sheets("Tab1")
lRowLst = .Cells(.Rows.Count, 1).End(xlUp).Row
lRowLst = IIf(.Cells(1, 1) = Empty, 1, lRowLst + 1)
.Cells(lRowLst, 1).Resize(UBound(aRngSrc, 1), UBound(aRngSrc, 2)).Value = aRngSrc
End With
End Sub
Once again let me know of any question you might have about the resources used.
As it is not possible to Copy more than one row at once when gaps are between as siddharth rout said we tried to bypass the problem with looping through every signle row which should be copiedand added an if query.
This code is working and i am using "him" now
j = 0
For i = 1 To 30
With Sheets("Arbeiter-Tage")
If Application.WorksheetFunction.CountA(.Columns(1)) <> 0 Then
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Else
lastRow = 1
End If
Sheets("Vorlage").Activate
If ActiveSheet.Range("V" & 25 + j).Value = 0 Then
ActiveSheet.Range("B" & 25 + j & ":" & "Q" & 25 + j).Copy
.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End With
j = j + 2
I need a formula or function which is going to fulfill my below mentioned need. I have a excel data of around 11000 rows and data looks somewhat like in Column A:
Now in column B i want the result to be printed like it mentioned below: which literally means it should count the values present in column A and print it in the column B, I don't need to repeat count:
Column A Column B
PC-101 1
PC-101 1
PC-102 2
PC-102 2
PC-103 3
PC-104 4
PC-106 5
PC-107 6
PC-104 4
PC-106 5
PC-106 5
I tried with the "count" series formulas but the result was null.
Even i wrote the macro as given below( which i got from stackoverflow) but even it is printing the repeating count:
Sub CountOccurence()
' Reference: Microsoft Scripting Runtime
Application.ScreenUpdating = False
Set oDict = New Dictionary
Dim wS As Worksheet
Dim r As Integer, rLast As Integer
Set wS = Sheet1
rLast = wS.Cells(1, 1).CurrentRegion.Rows.Count
For r = 3 To rLast Step 1
If Not (oDict.Exists(wS.Cells(r, 1).Value)) Then
oDict.Add wS.Cells(r, 1).Value, 1
Else
oDict.Item(wS.Cells(r, 1).Value) = oDict.Item(wS.Cells(r, 1).Value) + 1
End If
wS.Cells(r, 2).Value = oDict.Item(wS.Cells(r, 1).Value)
Next r
Set oDict = Nothing
Application.ScreenUpdating = True
End Sub
Can anyone help me regarding this? Thanks in advance.
I tried with the "count" series formulas but the result was null.
A simple Excel formula can do this.
Put 1 in Cell B1 and then put this formula in cell B2 and pull it down.
=IF(COUNTIF($A$1:$A2,A2)>1,VLOOKUP(A2,A:B,2,0),B1+1)
Assuming that your data in column a is sorted, you can simply place 1 in B2 this formula in B3 and copy it down:
=IF(A2<>A3,B2+1,B2)
:-)