I'm new to VBA. I'm trying to do crew scheduling, so one employee will do 28 days work and 28 days off and goes on for 10 employees.
This code works only from D4 and goes on. This is good but I need is the code to work on any empty cell I click. Say I select on G4 or H4 etc, it should start the copying from there.
Sub CopyToColumn2()
Dim lLastCol As Long
lLastCol = WorksheetFunction.Max(4, Cells(1, Columns.Count)_
.End(xlToLeft).Offset(, 1).Column)
Cells(1, lLastCol).Resize(1, 10).Value = Application.Transpose(Array(Range("B5")))
End Sub
Test Sheet:
You may perform a testing for using the following code modification, although it will only copy to D1 with resize method:
Sub CopyToColumn2()
Dim lastrow As Long, lastcol As Long, i As Long
lastrow = ActiveCell.Row
lastcol = ActiveCell.Column
For i = 0 To 3
Range(Cells(lastrow + i, lastcol), Cells(lastrow + i, lastcol + 9)).Value = Range("B6")
Next
End Sub
My sample data:
Related
I am using the macro below to keep cells only in a specified interval and remove the rest (i.e. keep the 1st, 5th, 10th, etc. point in a given column)
Dim i As Long
Dim lastRow As Long
lastRow = Application.ActiveSheet.UsedRange.Rows.Count
For i = 2 To lastRow Step 5
Range(Rows(i), Rows(i+8)).ClearContents
Next i
Currently, the macro deletes entire rows on the entire worksheet. I would like to modify the macro I can select the cell at the top of a single column I want to modify and run the macro only on that column.
For example, I have data in, say, A1:B350 and C1:E95 (both on the same sheet). I want to be able to run the macro and keep only a specified interval of cells in columns A-B without disturbing columns C-E. Likewise, I would like to run the same macro in column C without disturbing data in Column A. At this point, I am not sure how to modify this macro to meet this task. I'd greatly appreciate any help and guidance.
The following code will only affect the column you select, but I altered the step from 8 to 12 since otherwise all values were being cleared. Also, the usedRange function may not make sense since now only one column is the focus. Hopefully this code will get you started and you can adjust as needed.
Sub delColumnData()
Dim r As Range, col As Long, LastRow As Long, i As Long
Set r = Application.InputBox("select column", , , Type:=8)
col = r.Column
Set r = Cells(1, col)
LastRow = r.End(xlDown).row
For i = 2 To LastRow Step 12
Range(Cells(i, col), Cells(i + 8, col)).ClearContents
Next i
End Sub
To handle multiple columns:
Sub delColumnsData()
Dim r As Range, col As Long, LastRow As Long, i As Long, j As Long
Set r = Application.InputBox("select column(s)", , , Type:=8)
For j = 1 To r.columns.Count
col = r(j).Column
LastRow = r(j).End(xlDown).row
For i = 2 To LastRow Step 12
Range(cells(i, col), cells(i + 8, col)).ClearContents
Next i
Next j
End Sub
Another option
Option Explicit
Public Sub ClearColumnValues()
Dim i As Long, selectedCol As Long
selectedCol = Selection.Column 'in this case the Selection object can be convenient
With Application.ActiveSheet
For i = 1 To .UsedRange.Rows.Count Step 6
.Range(.Cells(i + 1, selectedCol), .Cells(i + 5, selectedCol)).ClearContents
Next
End With
End Sub
Gods of VBA,
Have been trying all morning to tweak this piece of amateur-VBA (in which case i'm the amateur) to perform as i want.
What is does now is the following; Looks for cell value 1 in Column O on the third sheet in my workbook. When it gets a hit, it copies the row which has 1 in Column O to a new worksheet called "Blad1". It then switches back to my 3rd sheet in the workbook "Doorvoeren".
It will loop and perform the task as wanted, only thing i can't get it to do is copy rows based on a variable in sheet "Doorvoeren". When this value is 5, i want it to copy the row with 1 in column O, and the 4 rows below it. (as example).
Could you please send me in the right direction here? Trying to make it work, but also learn from it in the process.
My code is added in the sample below:
Sub testIt()
Dim r As Long, endRow As Long, pasteRowIndex As Long
endRow = 500
pasteRowIndex = 5
For r = 3 To endRow
If Cells(r, Columns("O").Column).Value = 1 Then
Rows(r).Select
Selection.Copy
Sheets("Blad1").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
pasteRowIndex = pasteRowIndex + 1
Sheets("Doorvoeren").Select
End If
Next r
End Sub
EDIT: Thank you all for your answers, actually having real trouble to find one that works. To explain again; I need this VBA tweaked in the way that it looks at cell Q3, in sheet "Doorvoeren" to get the number of rows to copy. So, if Q3 is cell value; 5, i want it to to copy the row with number 1 in Column O, in Sheet "Doorvoeren", but also the other four rows below it.
So my 1 in Column O, is just a marker, not the number of rows i want to copy.
Please ask/tell me if i'm not being totally clear.
Here is my solution (slightly ammending your code with annotations)
Sub testIt()
'add another variable (called var)
Dim r As Long, endRow As Long, pasteRowIndex As Long, Var As Long
endRow = 500
pasteRowIndex = 5
For r = 3 To endRow
If Cells(r, Columns("O").Column).Value = 1 Then
'Grab the var number from the Doorvoeren sheet. Var will then determine how many rows need to be copied in each circumstance
Sheets("Doorvoeren").Select
Var = Cells(r, Columns("Q").Column).Value
Rows(r & ":" & r + (Var - 1)).Select
Selection.Copy
Sheets("Blad1").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
pasteRowIndex = pasteRowIndex + Var
Sheets("Doorvoeren").Select
End If
Next r
End Sub
It's recommended if you avoid using Select and ActiveSheet, instead use referenced Sheets and Ranges.
Option Explicit
Sub testIt()
Dim r As Long, endRow As Long, pasteRowIndex As Long
Dim PasteRow As Long
With Sheets("Doorvoeren")
' find last row with data in Column "O" in "Doorvoeren" sheet
endRow = .Cells(.Rows.Count, "O").End(xlUp).Row
For r = 3 To endRow
If .Cells(r, "O").Value = 1 Then
pasteRowIndex = 1
Else
If .Cells(r, "O").Value = 5 Then
pasteRowIndex = 5
End If
End If
' find last row with data in Column "O" in "Blad1" sheet
PasteRow = Sheets("Blad1").Cells(Sheets("Blad1").Rows.Count, "O").End(xlUp).Row
' copy number of rows from "Doorvoeren" sheet to "Blad1" sheet, paste them on the first empty row in "Blad1" sheet
.Range("O" & r).Resize(pasteRowIndex).EntireRow.Copy Destination:=Sheets("Blad1").Range("A" & PasteRow + 1)
Next r
End With
End Sub
I made a slight change upon your explanation.
'====================================================
Sub testIt()
Dim r As Long, endRow As Long, pasteRowIndex As Long
Dim DestR as Range
Dim Rloop as Range
dim RowsCounter as Integer
endRow = 500
pasteRowIndex = 5
RowsCounter = 0
For Each Rloop in Sheets("Doorvoeren").range("O3:O" & endRow)
if Rloop = 1 and RowsCounter=0 then RowsCounter = Rloop.Offset(0, 2)
If Rloop = 1 or RowsCounter > 0 Then
Set DestR = Sheets("Blad1").range("A" & pasteRowIndex)
Rloop.EntireRow.Copy DestR
pasteRowIndex = pasteRowIndex + 1
RowsCounter = RowsCounter - 1
End If
Next Rloop
End Sub
Hope this helps better :)
I am trying to write a macro for a simple Excel spreadsheet with only one column. Basically I have a long list (5000 rows or more). It is a list of numbered object IDs such as follows:
object_0001
object_0002
object_0003
...
object_5000
My goal is to add 5 rows of text and one blank row before each group of 90 objects. So it would look like this:
textadded1
textadded2
textadded3
textadded4
textadded5
(blank row here)
object_0001
object_0002
object_0003
object_0004
...
object_0090
textadded1
textadded2
textadded3
textadded4
textadded5
(blank row)
object_0091
object_0092
...
object_0180
textadded1
textadded2
textadded3
textadded4
textadded5
(blank row)
The 5 strings of text I want to add are all just a single word and will be the same string added between each block of 90 objects. Right now I have a macro that will insert blank rows and I am manually going through and copy/pasting the 5 cells of text in manually after I run it. This is the macro code I'm using that does that:
Sub CommandButton21_Click()
Dim LastRow As Long
Dim RowNdx As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For RowNdx = 95 To LastRow Step 95
Rows(RowNdx).Insert
Rows(RowNdx).Insert
Rows(RowNdx).Insert
Rows(RowNdx).Insert
Rows(RowNdx).Insert
Next RowNdx
'make sure the first FOUR lines are blank'
End Sub
Please help me modify the code to add in the text strings I want. This is all for a spreadsheet using only column A.
Try this macro:
Sub CommandButton21_Click()
Dim LastRow As Long
Dim RowNdx As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For RowNdx = 1 To LastRow Step 96
Rows(RowNdx).Insert
Rows(RowNdx).Insert
Cells(RowNdx, 1).Value = "textAdded5"
Rows(RowNdx).Insert
Cells(RowNdx, 1).Value = "textAdded4"
Rows(RowNdx).Insert
Cells(RowNdx, 1).Value = "textAdded3"
Rows(RowNdx).Insert
Cells(RowNdx, 1).Value = "textAdded2"
Rows(RowNdx).Insert
Cells(RowNdx, 1).Value = "textAdded1"
Next RowNdx
End Sub
Typically, when inserting or deleting rows in a loop you would start at the bottom and work up so that the inserted/deleted rows do not interfere with your iteration count.
Sub insert_6_every_90()
Dim rw As Long, lr As Long, stp As Long
stp = 90
With ActiveSheet 'set worksheet properly like With Sheets("Sheet1")!
lr = Int(.Cells(Rows.Count, 1).End(xlUp).Row / stp) * stp + 1
For rw = lr To 1 Step -stp
.Cells(rw, 1).Resize(6, 1).EntireRow.Insert
.Cells(rw, 1).Resize(5, 1).Formula = "=text(row(1:1), ""\t\e\x\t\a\d\d\e\d0"")"
.Cells(rw, 1).Resize(5, 1) = .Cells(rw, 1).Resize(5, 1).Value
Next rw
End With
End Sub
I'm not sure how close to the truth the Textadded0, Textadded1, etc was. This populates the five cells at once. If individual text was more appropriates, that portion would likely have to be adjusted.
I am trying to do some cuts to a sheet of data based on if a row meets 2 criteria in different columns, i.e. if the value in column D is > -2 and if the value in the adjacent cell of column F is > -2 or NA, then delete the entire row. If only 1 or none of the criteria is met then it should keep the row. Below is what i have so far. When i run the macro, it will go on forever, but I don't see how this should be since it doesn't look like an endless loop to me (to be fair i have only let it sit for 45 minutes, but there is only around 15,000 data rows so it shouldn't take longer than 10 minutes realistically). Any help would be greatly appreciated.
Sub Cuts()
Dim wb1 As Workbook, sh1 As Worksheet
Dim lastrow1 As Long, lastrow2 As Long
Set wb1 = Workbooks(“ovaryGisticARRAYRNAseq.final.xlsx")
Set sh1 = wb1.Sheets(“Cuts”)
lastrow1 = sh1.Cells(Rows.Count, 4).End(xlUp).Row
lastrow2 = sh1.Cells(Rows.Count, 6).End(xlUp).Row
For i = 1 To lastrow1
For j = 1 To lastrow2
If sh1.Cells(i, 4).Value > -2 Then
If sh1.Cells(j, 6).Value > -2 Then
sh1.Cells(j, 6).EntireRow.Delete
ElseIf sh1.Cells(j, 6).Value = “NA” Then
sh1.Cells(j, 6).EntireRow.Delete
End If
End If
Next j
Next i
End Sub
I'm not sure how you want to handle blank cells or text in column headings but I would propose this modification.
Sub Cuts()
Dim wb1 As Workbook
Dim lr As Long, i As Long
Set wb1 = Workbooks(“ovaryGisticARRAYRNAseq.final.xlsx")
With wb1.Sheets("Cuts")
lr = Application.Max(.Cells(Rows.Count, 4).End(xlUp).Row, _
.Cells(Rows.Count, 6).End(xlUp).Row)
For i = lr To 1 Step -1
If .Cells(i, 4).Value > -2 And _
(.Cells(i, 6).Value > -2 Or UCase(.Cells(i, 6).Value) = "NA") Then
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub
I have an excel workbook with 3 sheets, the first two contain lots of data and the third is blank.
I want to create a macro that copies all the highlighted/yellow cells from sheet 1 & 2 and pastes them in sheet 3.
I have some code in a macro which at the minute is only to copy sheet 1 to sheet 3 but it copies everything even though i have used If .Interior.ColorIndex
Sub Yellow()
Dim LR As Long, i As Long, j As Long
j = 1
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LR
With Worksheets("Sheet1").Range("A1:CF200" & i)
If .Interior.ColorIndex Like 27 Or 12 Or 36 Or 40 Or 44 Then
.Copy Destination:=Worksheets("Sheet3").Range("J" & j)
j = j + 1
End If
End With
Next i
End Sub
UPDATE: code below modified to skip yellow-highlighted cells that are blank...
I might break this one up into two sections, a script that does the looping through sheets and a function that checks if a cell (Range) is yellow. The code below has lots of comments which walk through the steps:
Option Explicit
Sub PutYellowsOnSheet3()
Dim Sh As Worksheet, Output As Worksheet
Dim LastRow As Long, LastCol As Long
Dim Target As Range, Cell As Range, Dest As Range
Dim DestCounter As Long
'initialize destination counter and set references
DestCounter = 1
Set Output = ThisWorkbook.Worksheets("Sheet3")
'loop through sheets that are not named "Sheet3"
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name <> "Sheet3" Then
With Sh
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set Target = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
For Each Cell In Target '<~ loop through each cell in the target space
If AmIYellow(Cell) And Cell.Value <> "" Then '<~ blank check too
Set Dest = Output.Cells(DestCounter, 1)
Cell.Copy Dest
DestCounter = DestCounter + 1 '<~ keep incrementing on sheet 3
End If
Next Cell
End If
Next Sh
End Sub
'call this function when you'd like to check if a range is yellow
Public Function AmIYellow(Cell As Range) As Boolean
If Cell Is Nothing Then
AmIYellow = False
End If
Select Case Cell.Interior.ColorIndex '<~ this is the yellow check
Case 27, 12, 36, 40, 44
AmIYellow = True
Case Else
AmIYellow = False
End Select
End Function
Your condition
.Interior.ColorIndex Like 27 Or 12 Or 36 Or 40 Or 44
always evaluates to True (any number except 0 is True) so in fact your condition is:
'condition' Or True Or True ...
should be:
`.Interior.ColorIndex Like 27 _
Or .Interior.ColorIndex Like 12 _
Or .Interior.ColorIndex Like 36 _
Or .Interior.ColorIndex Like 40 _
Or .Interior.ColorIndex Like 44`
or better rewritten as:
Select Case .Interior.ColorIndex
case 27,12,36,40,44
'action
Case Else
'do nothing
End Select
There are several mistakes to be found in your script. I think you want to loop all the cells in the given range and copy over only the cells that have the specified colors. That could be done like this:
Sub jzz()
Dim LR As Long, i As Long, j As Long
Dim c As Range
j = 1
LR = Range("A" & Rows.Count).End(xlUp).Row
For Each c In Worksheets("Blad1").Range("A1:G" & LR)
If c.Interior.ColorIndex = 6 Then
c.Copy Destination:=Worksheets("Blad2").Range("A" & j)
j = j + 1
End If
Next c
End Sub
You will need to modify the code somewhat, for example "Blad1" will not exist in your workbook, and I took only ColorIndex = 6