i need a simple vba code. I hope someone can help me.
So, I want to copy the range B2:E6 and leave some cells marked with a special condition. I created a rule in cells A2:A6 with the value Y / X. In the end, I want to paste the value B2:E6 in the range F9:I13 only if the value is Y.
I am attaching the following image to make it easier for you to understand.
Any help will be great. And sorry my english is bad.
Maybe this can get you started
Sub Macro1()
Dest = 8
For Row = 1 To 6
If Cells(Row, 1) <> "x" Then
Range(Cells(Row, 2), Cells(Row, 5)).Select
Selection.Copy
Cells(Dest, 6).Select
ActiveSheet.Paste
End If
Dest = Dest + 1
Next Row
End Sub
I recommend that you first define your working worksheet, if the CommandButton1 button code linked to the CommandButton1_Click() event, showen in your code, is not associated with your working sheet (Sheet9). Otherwise, the code will be executed on another Sheet than Sheet9, on which you want the conditions to be fulfilled.
So, I suggest this code, that formats also the target table "(F8:I13)":
Private Sub CommandButton1_Click()
Dim myWorkingSheet As Worksheet
Dim Working_Range As Range, Target_Range As Range
Dim Line_to_Read As Double, Table_Shift As Double
Set myWorkingSheet = Sheets("Sheet9")
myWorkingSheet.Activate
' Copy the header table
myWorkingSheet.Range("B1:E1").Copy Range("F8")
Application.CutCopyMode = False
' Copy the format of the table
myWorkingSheet.Range("B1:E6").Copy
myWorkingSheet.Range("F8").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
' Copy table if current cell in column A = "y"
Set Working_Range = myWorkingSheet.Range("A2:A6")
Line_to_Read = 2
Table_Shift = 7 'To start at F9 cell
For Each wr In Working_Range
If wr = "y" Then
myWorkingSheet.Range(Cells(Line_to_Read, 2), Cells(Line_to_Read, 5)).Copy myWorkingSheet.Range(Cells(Line_to_Read + Table_Shift, 6), Cells(Line_to_Read + Table_Shift, 10))
End If
Line_to_Read = Line_to_Read + 1
Next
' To point the cursor at the first cell.
myWorkingSheet.Cells(1, 1).Select
End Sub
To avoid the repetition of myWorkingSheet in the you use With clause and End With.
Related
I am creating a monthly report that copies cell values and pastes them onto specific rows depending on some simple criteria.
Pre Filter
I already have a IF function that =1 if my conditions are met. This is located in column C.
My goal is to copy 5 cells and simply paste-values them in the row that the filter = 1.
The following VBA has been myself playing with the option to filter to only show that specific row that =1, and then selection the 'Criteria 1', to paste in the first visible row below
Post Filter
Sub Macro11()
'
' Macro11 Macro
'
Dim PasteCell As Range
Set PasteCell = Range("F2").Offset(1, 0).Value 'F2 is the header for Criteria 1'
'Copy values from plan
ThisWorkbook.Worksheets("MonthlyDump").Range("N1:R1").Select
Selection.Copy
'Filter to only show the IF function = 1, plus blanks so the headings still show
ActiveSheet.Range("$C$1:$J$64").AutoFilter Field:=1, Criteria1:="1", _
Operator:=xlOr, Criteria2:="="
'Click on header, then pastes into first visible cell on the row below (the filtered row)
PasteCell.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Clear filters
ActiveSheet.Range("$C$1:$J$64").AutoFilter Field:=1
Range("A1").Select
End Sub
It currently fails on the first line 'Dim PasteCell As range', 424 object required.
But I am wondering if this is the best way to even go about this, ideally I would just like to look down column C until C65, and if it sees a 1, then pastes-values 3 cells to the right.
Is anyone able to come it with an elegant solution to this? My second option would be preferred as this seems the quickest way to a solution without requiring manually filtering.
Thanks
No. This doesn't look like the most suitable method. Please try the code below instead.
Sub Macro11()
' 204
Dim Arr As Variant ' temorary array
Dim Rng As Range ' temporary range
Dim Rt As Variant ' Row: target
Arr = ThisWorkbook.Worksheets("MonthlyDump").Range("N1:R1").Value
With ActiveSheet 'better to name the sheet (!)
' start lookin in row 3
Set Rng = .Range(.Cells(3, "C"), .Cells(64, "C"))
' same as above but last row is dynamic:-
' Set Rng = .Range(.Cells(3, "C"), .Cells(.Rows.Count, "C").End(xlUp))
Rt = Application.Match(1, Rng, 0)
If IsError(Rt) Then
MsgBox "No row matches the criteria.", _
vbExclamation, "Failed to post"
Else
.Cells(Rt + Rng.Row - 1, "D").Resize(1, UBound(Arr, 2)).Value = Arr
End If
End With
End Sub
This code uses the MATCH function to find the first 1 in column C. Actually, this looks like not being the optimum, either. It should be possible to look for the conditions that you use to set column C to 1 and 0, perhaps a date. If the code would look for the date, or whatever other criterium, instead of the 1 column C wouldn't be needed.
I need your help. I'm trying to run a macro on every row of a table. I want to have the first and the last interaction date with all clients of the list. What I already did on a macro is to copy the first date from a sheet2 and paste it on sheet1 to get the first date, then with CTRL-Down do it again with the next date to get the last date. However, since it's not a loop, it only does it on the cells I did it. (Down is the code I have). I would like the code to do the same thing on every cell, until the end of the table.
I have attached screenshot of the two sheets. I hope I made myself clear and I hope someone can help you out.
sheet1 sheet2
Sheets("Total").Select
Range("D6923").Select
Selection.End(xlDown).Select
Selection.Copy
Sheets("Timeline").Select
ActiveSheet.Paste
Range("C189").Select
Sheets("Total").Select
Selection.End(xlDown).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Timeline").Select
ActiveSheet.Paste
Range("B190").Select
Sheets("Total").Select
Selection.End(xlDown).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Timeline").Select
ActiveSheet.Paste
Range("C190").Select
Sheets("Total").Select
Selection.End(xlDown).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Timeline").Select
ActiveSheet.Paste
I can see you are very new to this and that is fine, we all were once! Using recorded macros is a good way to see how excel views what you are doing at the time but it is extremely inefficient compared to what it could be. As Ron has mentioned, select really is not a friend of efficient code. For example, your first four lines could be rewritten into one line as:
Sheets("Total").Range("D6923").End(xlDown).copy
However even this isn't the best way. I'm going to assume that you are working from the top of your sheet to the bottom and answer your question based on what I think you are trying to do. I'm also assuming that your sheet called Timeline is sheet 1 and your sheet called Total is sheet 2. Within total I am assuming that any number of entries could be there rather than just the two shown in the three examples given.
Sub ExampleCode()
'Variables, you can create and store things in VBA to make life easier for you
Dim Wb as Workbook 'This is the workbook you are using
Dim wsTimeline as Worksheet 'This is your worksheet called Timeline
Dim wsTotal as Worksheet 'This is your worksheet called as Total
Const rMin as byte = 5 'This is where the loop will start, I'm assuming row 5. As _
this won't change throughout the code and we know it at the _
start it can be a constant
Dim rMax as long 'This will be the last row in your loop
Dim r as long 'This will be how your loop knows which row to use
Dim timelineRow as long 'This will be the row that the data is pasted in Timeline
Dim timelineLastRow as Long 'This is the last row of data in your timeline sheet
Set Wb = Thisworkbook 'Your whole workbook is now stored in the variable Wb
Set wsTimeline = Wb.Sheets("Timeline") 'As the workbook was stored in Wb we can use it as _
shorthand here. Now the sheet Timeline is in wsTimeline
Set wsTotal = Wb.Sheets("Total") 'Same as above, this sheet is now stored
rMax = wsTotal.Cells(Rows.Count, 1).End(xlUp).Row 'This is the equivalent of starting at the _
bottom row in column A and pressing _
Ctrl+Up. This takes you to the last _
row of data in column A. …(Rows.Count, 2)… _
would be column B etc.
timelineLastRow = wsTimeline.Cells(Rows.Count, 1).End(xlUp).Row
'This is the bit where you start to loop, the line below basically says "Do the code in this _
loop for every value between rMin and rMax, each time make 'r' that value (r for row!)
With wsTotal 'Means that anything below starting with '.' will _
be the same as 'wsTotal.'
For r = rMin To rMax
'Ensure working on a line with data
If .Cells(r, 1) = "" Then
r = .Cells(r, 1).end(xlDown).row
If r > rMax Then
End With 'Closes the With statement above as no longer needed.
Exit For 'Exits the loop as we have ended up beyond rMax
End if
End if
'This will look for the person in wsTimeline and if they aren't there then add them
If IsError(Application.Match(.Cells(r, 1), wsTimeline.Range("A3:A" & timelineLastRow), 0)) Then
wsTimeline.Cells(timelineLastRow + 1, 1) = wsTotal.Cells(r, 1)
timelineRow = timeLineLastRow + 1
timelineLastRow = timelineRow
Else
timelineRow = Application.Match(.Cells(r, 1), wsTimeline.Range("A3:A" & timelineLastRow), 0)
End If
'I'm assuming that all records in 'Total' are chronologically ascending with no gaps between _
each row for a single person.
wsTimeline.Cells(timelineRow, 3) = .Cells(r + 2, 4)
If .cells(r + 3, 4) <> "" then
wsTimeline.Cells(timelineRow, 4) = .Cells(r + 2, 4).End(xlDown)
Else
wsTimeline.Cells(timelineRow, 4) = .Cells(r + 2, 4).End(xlDown)
End If
'Now that the data has been brought across from Total to Timeline we can move on to _
the next row.
Next r 'This will add one to the value stored in r and start the code again where _
the loop started
End With
'The loop has now ended having gone through every row in your worksheet called Total.
End Sub
I created a macro in my excel sheet
The aim of the macro is to copy the cells in one column, one by one (L1,L2...), into a specific cell (A1). then after the calculations are done, copy the value from another cell E2, to the column next to L, meaning to M1, M2...
i couldn't know how to loop these steps to all the cells in the column.
Sub Checking_Frequences()
'
' Checking_Frequences Macro
'
'
Range("L1").Select
Selection.Copy
Range("A1").Select
ActiveSheet.Paste
Range("E2").Select
Application.CutCopyMode = False
Selection.Copy
Range("M1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("L2").Select
Application.CutCopyMode = False
Selection.Copy
Range("A1").Select
ActiveSheet.Paste
Range("E2").Select
Application.CutCopyMode = False
Selection.Copy
Range("M2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
is there a way to add a delay, so that excel finish calculations before copying the result from E2?
any advice?
regards
Your workbook can do with a little organisational upgrading. I may not have done it the way you best like but I think the code below will let you take a big step forward. Install it in a standard code module and run only the procedure WriteArrays. Take time to understand how it works first.
Sub WriteArrays()
' 043
' number of results wanted from each Base
Const Iterations As Integer = 5 ' adjust to suit
Const TgtTab As String = "Sheet3" ' Output tab (change to suit)
Const TgtRow As Long = 2 ' modify to suit
Const TgtClm As Long = 4 ' first output column (modify to suit)
Dim Src As Variant ' array of source Base numbers
Dim R As Long ' SrcRng row counter
Dim WsTgt As Worksheet ' Target worksheet (for output)
Dim Arr As Variant ' value to write to sheet
Dim Operand As Double ' calculated by a formula
Dim i As Long ' loop counter
Operand = 2 ^ (1 / 12) ' = 1.0594630943593 (adjust to suit)
With Worksheets("Frequencies")
' set the range L1:L(last used row) - modify to suit
' read all values into an array
Src = .Range(.Cells(1, "L"), .Cells(.Rows.Count, "L").End(xlUp)).Value
End With
Set WsTgt = Worksheets(TgtTab)
For R = LBound(Src) To UBound(Src)
Arr = BaseArray(Src(R, 1), Operand, Iterations)
With WsTgt.Cells(TgtRow, TgtClm - 1 + R).Resize(UBound(Arr))
.Value = Application.Transpose(Arr)
.NumberFormat = "0.00"
End With
' If R = 5 Then Exit For
Next R
End Sub
Private Function BaseArray(ByVal Base As Double, _
ByVal Operand As Double, _
ByVal Iterations As Integer) As Variant
' 043
Dim Fun As Variant ' function return value
Dim i As Integer
ReDim Fun(1 To Iterations)
For i = LBound(Fun) To UBound(Fun)
Fun(i) = Base
Base = Round(Base * Operand, 2)
Next i
BaseArray = Fun
End Function
There are 4 constants at the top of the code which you will have to set. The last 3 deal with the output. You asked for output in column M on the same sheet. But this code will add 235 columns. So I thought it better to start a new sheet. You can easily run the code multiple times with different parameters and output the results on different sheets. But they must exist before the code is run.
Const Iterations specifies how many rows there will be in each column. You seem to want 50. I tested with only 5. Modify this constant to suit your needs.
A little further down there is the Operand which is the formula taken from your cell C1. It can be changed.
Of course, the tab Frequencies must exist and it must have numbers in column L. You can start from row 2 instead of 1. But if you want to limit the output you may like to avail yourself of the method I used, here: If R = 5 Then Exit For (at the end of the Next ../.. For loop). It just curtails the loop after 5 numbers from the list, if you enable the line by removing the leading apostrophe.
I wish you the best of luck with your venture :-)
I am working on a Macro in Excel that will make a copy of the current worksheet and paste the values into a new worksheet. The worksheet name would be the same just with a number after it [ie Sheet, Sheet1(2)]
My code does this correctly except that it copies and pastes everything to Sheet1(2). I only want it to paste the values (not formulas) from Sheet1 to Sheet1(2). I'm a novice at vba at best so any suggestions are greatly appreciated.
Sub SPACER_Button4_Click()
' Compile Button to Generate Quote
'
'variables definitions
ActiveSheetValue = ActiveSheet.Name
'
'This section creates a copy of the active worksheet and names it with the next corresponding number
Sheets(ActiveSheetValue).Copy After:=Sheets(ActiveSheetValue)
'This section should look for X value in each row, column 4. If value equals X, it deletes the row on the copied sheet
Dim i As Integer
i = 26
Do Until i > 300
If ActiveSheet.Cells(i, 11).Value = "X" Then
Rows(i).Delete
Skip = True
End If
'
If Skip = False Then
i = i + 1
End If
'
Skip = False
Loop
'This part hides columns on Right K thru R of new copied sheet
Sheets(ActiveSheet.Name).Range("K:R").EntireColumn.Hidden = True
End Sub
If the data is contiguous, consider creating a new sheet, selecting and copying the range of data, and pasting onto the new sheet using the below code.
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
I use something like this:
Sub KopyKat()
Dim s1 As Worksheet, s2 As Worksheet
Dim r As Range, addy As String
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
For Each r In s1.UsedRange
If r.Value <> "" Then
If Not r.HasFormula Then
addy = r.Address
r.Copy s2.Range(addy)
End If
End If
Next r
End Sub
I have written the following code to copy and paste range w21:W1759 into range AD21:
Sub CommandButton1_Click()
Dim i As Integer, j As Integer
For j = 1 To Range("d7")
Range("d8") = j
'Calculate
Range("w21:W1759").Select
Selection.Copy
Range("AD21").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Next j
End Sub
My data in range w21:W1759 is set to change (due to random sampling) on every click and I want the new data in this range to be copied and pasted to range "ae" (the adjacent column). Then on the next click to "af" and so on and so on. What code do I need to add to the above to achieve this?
Thanks very much for the help
This will depend somewhat on what is to the right of column AC. If column Ad is the first empty column then it is easy to copy to. Subsequent copying operations can use the same next-empty-column method to fill columns AE, AF, etc.
Sub CommandButton1_Click()
Dim i As Long, j As Long
With Worksheets("Sheet1")
For j = 1 To .Range("d7")
.Range("d8") = j
.Calculate
With .Range("w21:w1759")
.Parent.Cells(21, Columns.Count).End(xlToLeft).Offset(0, 1).Resize(.Rows.Count, .Columns.Count) = .Value
End With
Next j
End With
End Sub
I've altered your Copy, PasteSpecial Values method to be a direct value transfer. This is faster and does not involve the clipboard.