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.
Related
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:
I'm trying to copy/paste information between three different Sheets.
The first two I only want to compare information with a If and if the condition is met then from sheet n2 copy all rows to a third sheet. My problem is that the code only finds the first value and stops. Here's the code.
Sub fallidas2()
Dim iLastRow As Long
Dim I As Long
Dim l As Long
Dim erow As Long
erow = Sheets("Failed_Trades").Range("A" & Rows.Count).End(xlUp).Row + 1
Workbooks("modelo titulos UK").Worksheets("xlsConsultaConciliacion").Select
iLastRow = Worksheets("xlsConsultaConciliacion").Cells(Rows.Count, "C").End(xlUp).Row
iLastRow2 = Worksheets("Fallidas").Cells(Rows.Count, "C").End(xlUp).Row
For I = 3 To iLastRow
For l = 2 To iLastRow2
If Sheets("xlsConsultaConciliacion").Cells(I, 1) = Sheets("Fallidas").Cells(l, 2) Then
Worksheets("Fallidas").Rows(I).EntireRow.Copy _
Destination:=Sheets("Failed_Trades").Range("A" & erow)
End If
Next l
Next I
End Sub
You need to increment erow as part of the If statement. I've also included an Exit For statement in there so that it doesn't keep searching through the 2nd worksheet after the first match is found. But maybe you want it to find additional matches and populate the same information repetitively on the third sheet?
If Sheets("xlsConsultaConciliacion").Cells(i, 1) = Sheets("Fallidas").Cells(l, 2) Then
Worksheets("Fallidas").Rows(i).EntireRow.Copy Destination:=Sheets("Failed_Trades").Range("A" & erow)
erow = erow + 1
Exit For
End If
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 need some help with this macro. I have a workbook that is formatted pretty poorly, but consistently every time I open it. Among other things, the goal is to find the non-blank cells in column B and delete the entire 2 rows below and the 1st row above each of those populated B cells.
The first loop I have in the code works just the way I want it to, but the second loop seems to only work on the 1st instance of a populated B cell, but then it deletes everything else above it, like 500 cells worth of data.
Can someone explain to me why this is happening, and if you could find a way to combine both of those for loops into 1, that would be nice too.
Sub test()
Dim currentSht As Worksheet
Dim startCell As Range
Dim lastRow As Long, lastCol As Long
Dim colNames As Variant
Dim i As Integer, j As Integer
Set currentSht = ActiveWorkbook.Sheets(1)
Set startCell = currentSht.Range("A1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For i = lastRow To 1 Step -1
If currentSht.Cells(i, "B").Value <> "" Then
currentSht.Cells(i, "B").Offset(1).EntireRow.Delete
End If
Next i
Range("D3").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlUp
currentSht.Rows("1:1").EntireRow.Delete
currentSht.Range("c:d, f:g, i:k").EntireColumn.Delete
currentSht.Range("A:D").Columns.AutoFit
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").Value <> "" Then
currentSht.Range(Cells(j, "B").Offset(-1), Cells(j, "B").Offset(-3)).EntireRow.Delete
End If
Next j
End Sub
Thank you
The second loop deletes everything because upon deletion of the lines above the found value, said value gets moved up and will be found again, triggering another deletion. To fix this, the quickest way would be to skip the next two lines by modifying j:
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").Value <> "" Then
currentSht.Range(Cells(j, "B").Offset(-1), Cells(j, "B").Offset(-3)).EntireRow.Delete
j = j - 2
End If
Next j
It really doesn't matter much if you are looping from top to bottom or vice versa. The only difference would be if there are two entries in column B near each other. In that case, the search order would determine which one is deleted. But is deletion really what you want? Maybe you could .Clear the contents of the rows instead of deleting them.
edit: here's the new code a bit cleaned up
Sub test()
Dim currentSht As Worksheet
Dim startCell As Range
Dim lastRow As Long, lastCol As Long
Dim colNames As Variant
Dim i As Integer, j As Integer
Set currentSht = ActiveWorkbook.Sheets(1)
Set startCell = currentSht.Range("A1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For i = lastRow To 1 Step -1
If currentSht.Cells(i, "B").value <> "" Then
'reference the row directly
currentSht.Rows(i + 1).Delete
End If
Next i
'Do not use selection if you can avoid it
Range("D3", Range("D3").End(xlToRight)).Delete Shift:=xlUp
currentSht.Rows(1).Delete
currentSht.Range("C:D, F:G, I:K").Delete
currentSht.Range("A:D").Columns.AutoFit
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").value <> "" Then
currentSht.Rows(j - 1).Delete
currentSht.Rows(j - 2).Delete
j = j - 2
End If
Next j
End Sub
If you want to combine the loops the behavior of the macro will change because of the deletions that happen between the loops.
I run a daily report of our account details and the headers on the Excel file are always mis-aligned. I would like a macro to help with this, but I am a beginner with macros and don't even know where to start.
On any active sheet, I would like to find a specific word in column B ("Trx Date") and move the row over 1 to the left. The reports will always have the same column format, but the rows can fluctuate depending on the amount of detail.
"Trx Date" is the first header title, but it starts in column B and all the data starts in column A. There is other information in column B so the word "Trx Date" would need to be found first. Any ideas? I am new to the site so it will not allow me to upload an image. Thank you all!
This is what I was trying with no luck.....
Dim Firstrow As Long
Dim Lastrow As Long
Dim FinalRow As Long
With ActiveSheet.Select
Firstrow = 7
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).row
For FinalRow = Lastrow To Firstrow Step -1
With .Cells(FinalRow, "B")
If Not IsError(.value) Then
Select Case .value
Case Is = "Trx Date": .Offset(, -1).Delete Shift:=xlLeft
End Select
End If
End With
Next FinalRow
End With
This should work
Dim Firstrow As Long
Dim Lastrow As Long
Dim FinalRow As Long
Firstrow = 7
Lastrow = Cells(Rows.Count, 2).End(xlUp).Row
For FinalRow = Lastrow To Firstrow Step -1
With Cells(FinalRow, 2)
Select Case .Value
Case "TRX Date": Cells(FinalRow, 1).Delete Shift:=xlToLeft
End Select
End With
Next FinalRow