I am trying to write some VBA that does two things:
When a value J column = "XY" duplicate the row by inserting the same data into a row below
In the newly inserted row, change values in G, H & L to "0"
So far, I have found this, which works to insert a blank row but I cannot figure out how to do the rest:
Dim i As Range
Dim cell As Range
Set i = Range("J:J")
For Each cell In i.Cells
If cell.Value = "XY" Then
cell.EntireRow.Copy
cell.Offset(1).EntireRow.Insert
End If
Next
The above inserts a blank row but I also need to copy and paste the row above its values and change some.
When inserting/deleting rows it's usually best to loop from the bottom up.
That's what the following, simple, example does.
Sub InsertXY()
Dim idx As Long
For idx = Range("J" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("J" & idx).Value = "XY" Then
Rows(idx).Copy
Rows(idx + 1).Insert Shift:=xlDown
Intersect(Rows(idx + 1), Range("G:H, L:L")).Value = 0
End If
Next idx
End Sub
Before
After
Related
I want to delete empty rows, such as 3-10 and 16-19. I tried the following code but it is also deleting rows 1, 2 and 15.
Dim s1 as worksheet
Dim LastRow As Long
Set s1 = ThisWorkbook.Worksheets(9)
LastRow = s1.Range("D" & s1.Rows.Count).End(xlUp).Row
With s1.Range("D2:D" & LastRow)
If WorksheetFunction.CountBlank(.Cells) > 0 Then
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
End With
Looking at #cybernetic.nomads comment, and the fact that I just had a quick go, there will be a better way to do this.
If you want to delete all the empty rows, you'll (probably) need a loop.
When you delete a row your code needs to take in to account that the row numbers change (delete row 1, and now row 2 is actually row 1). You can do this by looping backward, or by re-trying the current row until all empty rows are gone then increase the row number (like my example)
Sub main()
Dim Sheet As Worksheet: Set Sheet = ThisWorkbook.Worksheets("Sheet1")
Dim Row As Integer: Row = 2 ' start row
Do
If Row > Sheet.Range("D" & Sheet.Rows.Count).End(xlUp).Row Then ' break out once you've gotten to the end
Exit Do
End If
If Application.WorksheetFunction.CountA(Sheet.Rows(Row)) = 0 Then ' check if the row is empty
Sheet.Rows(Row).Delete xlShiftUp ' delete the row and shift up
Else
Row = Row + 1 ' row was not empty, move on to the next row
End If
Loop
End Sub
your code check only column D and deletes blanks there.
text in lines 1, 2 and 15 are in columns A and B.
perhaps you could use this twist in your code?
while removed, instead i is used to check single rows
Rows are checked from bottom up
if a row has 4 blanks in columns A:D, this row is deleted
Code
Dim s1 As Worksheet
Dim LastRow As Long
Dim i As Long
Set s1 = ThisWorkbook.Worksheets(9)
LastRow = s1.Range("D" & s1.Rows.Count).End(xlUp).Row
If WorksheetFunction.CountBlank(s1.Range("A2:D" & LastRow).Cells) > 0 Then
For i = 1 To LastRow - 2: '-2 means: row 2 will be checked last. Use '-1' to check row 1 as well
If WorksheetFunction.CountBlank(Range(Cells(LastRow - i, 1), Cells(LastRow - i, 4))) = 4 Then
Rows(LastRow - i).Delete
End If
Next i
End If
Note: if you are not dealing with many rows, you might consider using integer Instead of Long
A simple solution is to check last column to garantee entire empty row
lastline = s1.Cells(Rows.Count, 4).End(xlUp).Row
i = lastline
While (i > 0)
If (s1.Cells(i, Columns.Count).End(xlToLeft).Column = 1 And s1.Cells(i, 1).Value = "") Then
s1.Rows(i).EntireRow.Delete
End If
i = i - 1
Wend
Note that the loop is backwards because (i) delete a row reindex all of the others next and (ii) classical for condition (for i = 1 to lastline) is checked just once.
I am trying to write a code that adds in data from my excel sheet if the item the user selects is equal to the range in J. This works perfectly if the range in J is filled in with all the data, but how do I get the row to still count all the way through the last filled cell if there are blanks in between? I attached a picture to show what I mean.
.
I would want to count the rows all the way down to the last "Gold". Right now it only counts to the second.
Private Sub cboName_Click() 'only get values that are assigned
Dim j As Integer, k As Integer, i As Integer
Me.lstProvider.Clear
i = 0
Worksheets("Biopsy Log").Select
For j = 1 To Range("J2", Range("J1").End(xlDown)).Rows.count
If Range("J2", Range("J2").End(xlDown)).Cells(j) = Me.cboName.Value Then
If Range("C2", Range("C2").End(xlDown)).Cells(j) = "Assigned" Then
With Me.lstProvider
.AddItem
For k = 0 To 5
.List(i, k) = Range("A" & j + 1).Offset(0, k)
Next
End With
i = i + 1
End If
End If
Next
End Sub
Instead of For j = 1 To Range("J2", Range("J1").End(xlDown)).Rows.count use Range("J" & Rows.Count).End(xlUp).Row (assuming GOLD is in column J). The code does the opposite of xlDown. It goes down to the last row of the sheet (Rows.count) and moves up until it find the first non-blank cell.
Instead of using xlDown, try to use xlUp from the bottom to get the last row for correct range:
Dim sht As Worksheet
Set sht = Worksheets("Biopsy Log")
For j = 1 To sht.Range("J" & sht.Rows.Count).End(xlUp).Row
If sht.Range(...)
Qualifying Range calls with an explicit Worksheet object makes your code more robust.
I am trying to create a summary list for people in a downstream application to feed several of my production machines. Each machine is going to have their own tab to request material, and I want all of their requests to be summarized on one tab (called "Core_Cutter_List").
So basically I am trying to create a VBA that will copy over a row from spreadsheet "2" into the next blank line on spreadsheet "Core_Cutter_List". I want it to copy if there is text in column A and column G is blank. I have limited knowledge of VBA. The code that I found was able to only test for one of my criteria which was that column G is blank, but basically it runs through every single cell on my file. Do you know how I can add the other criteria of column A having text in it so that it doesn't look through every cell on my sheet? Thanks for any help!
Sub Test()
'
' Test Macro
'
Sheets("2").Select
For Each Cell In Sheets(1).Range("G:G")
If Cell.Value = "" Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Core_Cutting_List").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("2").Select
End If
Next
End Sub
If you need two conditions, then you should write them carefully in the IF statement with And:
Something like If cell.Value = "" And Len(cell.Offset(0,-6)) Then should be workable.
Using Select is a bit not advisable, but it works at the beginning - How to avoid using Select in Excel VBA
The Sub bellow does the following
Determine the last used row in Worksheets("2") based on values in column A
Determine the last used col in Worksheets("2") based on values in row 1
Determine the last used row in Worksheets("Core_Cutter_List") based on values in column A
Loop through all used rows in Worksheets("2")
If the cell in col A is not empty And cell in col G is empty
Copy entire row to next empty row in Worksheets("Core_Cutter_List")
Increment next empty row for Worksheets("Core_Cutter_List")
Loop to the next used row in Worksheets("2")
Option Explicit
Public Sub CopyRows()
Dim ws1 As Worksheet, ws2 As Worksheet, ws1r As Range, ws2r As Range
Dim ws1lr As Long, ws1lc As Long, ws2lr As Long, i As Long
Set ws1 = ThisWorkbook.Worksheets("2")
Set ws2 = ThisWorkbook.Worksheets("Core_Cutter_List")
ws1lr = ws1.Range("A" & Rows.Count).End(xlUp).Row 'last row in "2"
ws1lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column 'last col in "2"
ws2lr = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1 'last row in "Core_Cutter"
For i = 1 To ws1lr
If Len(ws1.Cells(i, "A")) > 0 And Len(ws1.Cells(i, "G")) = 0 Then
Set ws1r = ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, ws1lc))
Set ws2r = ws2.Range(ws2.Cells(ws2lr, 1), ws2.Cells(ws2lr, ws1lc))
ws2r.Value2 = ws1r.Value2
ws2lr = ws2lr + 1
End If
Next i
End Sub
My test file
Worksheets("2")
Worksheets("Core_Cutter_List")
I am trying to replicate this view where new rows in the bottom table are created based on the values in Column'A' of the top table.
Here is my code:
Sub testProc()
Worksheets("Sheet1").Activate
Dim r, count As Range
Dim LastRow As Long
Dim temp As Integer
'Dim lngLastRow As Long
Set r = Range("A:L")
Set count = Range("A:A")
LastRow = Range("F" & 9).End(xlUp).Row
'LastRow = Cells(Rows.count, MyRange.Column).End(xlUp).Row
For n = LastRow To 1 Step -1
temp = Range("A" & n)
If (temp > 0) Then
Rows(n + 1 & ":" & n + temp).Insert Shift:=xlDown
Range("H" & (ActiveCell.Row) - 2).Copy Range("E" & (ActiveCell.Row) - 1)
Range("G" & (ActiveCell.Row)).Select
'ActiveCell.Offset(RowOffset:=1, ColumnOffset:=-6).Activate
'Cells(ActiveRow, 8).Value.Cut
'Cells.Offset(2 - 6).Value.Paste
'Range("G" & (ActiveCell.Row)).Select
'ActiveCell.Offset(0 - Selection.Column + 1).Range("A1:AG1").Select
'Value = Range(G, H)
'ActiveCell.Offset(1, -6).Paste
'ActiveCell.Offset(1, -6).Paste
'ActiveCell.Offset(RowOffset:=1, ColumnOffset:=-6).Paste
'Range.Offset(1, -6).Paste
'Value = Range("G" & (ActiveCell.Row), "H" & (ActiveCell.Row)).Value
'ActiveCell.Offset(2, -6).Range
'ActiveCell.Offset(rowOffset:=3, columnOffset:=3).Activate
End If
Next n
End Sub
I do not know what I am doing and Excel is crashing with and without messages
The easiest solution to this would be to use two separate worksheets, but you can work around this pretty easily with some math or a cell with a reserved word. You also want to use as few reference variables as possible and let Excel tell you what the ranges are defined as by using contiguous ranges.
I'm not going to write the whole function for you, but give you the building blocks that will let you piece it together and hopefully you'll learn more as you do it.
Here's how to set up the object variables that you'll reference throughout the code:
Dim sourceSheet as Worksheet
Dim targetSheet as Worksheet
' replace with the names of sheets you want to use
sourceSheet = Worksheets("Sheet1")
targetSheet = Worksheets("Sheet2")
Now, for looping through the source table. If you know that the first row in the Sheet is always the Title row and your instructions start in row 2 then you can use this to loop through every instruction:
Dim sourceRowIndex = 2
While Not IsEmpty(sourceSheet.cells(sourceRowIndex, 1))
' ** do stuff here
' increment row index
sourceRowIndex = sourceRowIndex + 1
Wend
You could also use a For Each loop or a For Next or a Do While, take your pick once you understand the logic used.
Note that "Cells" takes two numbers - the row number then the column number. This is very handy when you're looping through a series of rows and columns and don't want to have to deal with addresses like A1 or C5.
This will loop through everything in the top table, but now you need to add an inner loop that will actually process the instructions. Add all of the code below after the While and before the Wend.
Finally, you need to add the rows to the Target. The trick here is to use the CurrentRegion property to figure out where the last row in the range is, then just add one to get the next blank row.
Dim targetFirstEmptyRow
' Look up the Current Range of cell A1 on target worksheet
targetFirstEmptyRow = targetSheet.cells(1,1).CurrentRegion.Rows + 1
Then to assign values don't use copy and paste, just assign the values directly. This will write the first row you have defined:
targetSheet.cells(targetFirstEmptyRow, 1).value = sourceSheet.cells(sourceRowIndex, 1).value
targetSheet.cells(targetFirstEmptyRow, 4).value = sourceSheet.cells(sourceRowIndex, 4).value
targetSheet.cells(targetFirstEmptyRow, 5).value = sourceSheet.cells(sourceRowIndex, 5).value
Then after you write out those three values you can get the next empty row by using this again (note that your sourceRowIndex hasn't changed):
targetFirstEmptyRow = targetSheet.cells(1,1).CurrentRange.Rows + 1
Using the cells(row, column) logic it's pretty easy to write the second row as well:
targetSheet.cells(targetFirstEmptyRow, 2).value = sourceSheet.cells(sourceRowIndex, 6).value
targetSheet.cells(targetFirstEmptyRow, 3).value = sourceSheet.cells(sourceRowIndex, 7).value
targetSheet.cells(targetFirstEmptyRow, 6).value = "Dev"
Adding the third row (when it's required) is nearly exactly the same as the second. However, you want to check to see if the third row is necessary:
If sourceWorksheet.cells(sourceRowIndex, 1) = 3 Then
' insert your third row here
End If
Here's the entire function in pseudo-code so you can piece it all together:
Set up worksheet variables
While loop through every Source row
Find next empty row in Target
Copy Row 1
Find next empty row in Target
Copy Row 2
If 3 rows
Find next empty row in Target
Copy Row 3
Increment Source Row Index
Wend
Finally, if you don't want to see the screen flashing (and you want to speed the code execution up a little) look into Application.Screenupdating to turn off screen redraw as this does its work. Just remember to turn it on again once you've finished processing everything.
Basically I have the following scenareo:
2 columns, with 600 rows of data.
I need to copy the data from column 2 and place it at the end of the content in column1 for the same rows. This would result in column 1 having its original content plus the additional content of column 2.
Any information in how I can do this will be greatly appreciated.
Thanks in advance!
Here's a VBA in a simple form. Just create a macro, add these lines to it. Then select your original column (what you're calling column 1), and run the macro.
a = ActiveCell.Value
b = ActiveCell(1, 2).Value
ActiveCell.Value = a + b
The bracketed cell reference is a relative statement - 1, 2 means "same row, one column to the right" so you can change that if you need. You could make it loop by expanding thusly:
Do
a = ActiveCell.Value
b = ActiveCell(1, 2).Value
ActiveCell.Value = a + b
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "" Then
Exit Do
End If
Loop
That loop will carry on until it finds a blank cell, then it'll stop. So make sure you have a blank cell where you want to stop. You could also add extra characters into the line that combines.. so in the above example it's ActiveCell.Value = a + b, but you could make it ActiveCell.Value = a + " - " + b or anything else that may help.
This should take the values from column 2 and place them sequentially at the bottom of column 1.
Sub test()
Dim rng1 As Range
Dim rng2 As Range
Dim cl As Range
Dim r As Long
Set rng1 = Range("A1", Range("A1048576").End(xlUp))
Set rng2 = Range("B1", Range("B1048576").End(xlUp))
r = rng1.Rows.Count + 1
For Each cl In rng2
Cells(r, 1).Value = cl.Value
r = r + 1
Next
End Sub
Just keep it simple. Here is the code.
Sub copyCol()
Dim lastRow As Long
lastRow = Range("A65000").End(xlUp).Row
Range("B1:B" & lasrow).Copy Range("A" & lastRow).Offset(1, 0)
End Sub
As this question received a number of views (10,000+) I thought it was important to also share another and far simpler solution:
In cell C1 use the formula:
=(A1 & B1)
This will copy the content of cell A1 and B1 into cell C1. Drag the formula to all other rows (row 600 in my case).
Then copy the column and paste using 'values only'.
You will then have cells in column C containing the content of column A and column B in a single cell on a row-to-row basis.