I need to insert rows according to the condition that the cell in DQ column is non-blank then I have to insert a new row, and also paste the row data in the new row data.
The problem is that I am not able to insert a row above the matched column and also I don't know how to copy the text.
Following is the code that I have:
Sub Macro()
nr = Cells(Rows.Count, 5).End(xlDown).Row
For r = 4 To nr Step 1
If Not IsEmpty(Cells(r, 121).Value) Then
Rows(r + 1).Insert Shift:=xlDown
Rows(r + 1).Interior.ColorIndex = 16
End If
Next
End Sub
For this you will have to use a reverse loop. I quickly wrote this code and it is not tested. Let me know if you get any error.
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, r As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Get the last row which has data in Col DQ
lRow = .Cells(.Rows.Count, 121).End(xlDown).Row
'~~> Reverse Loop
For r = lRow To 4 Step -1
If Not IsEmpty(.Cells(r, 121).Value) Then
.Rows(r + 1).Insert Shift:=xlDown
.Rows(r + 1).Interior.ColorIndex = 16
End If
Next
End With
End Sub
I actually found the answer in this forum itself. Pasting the code and the link. Thanks a lot people.
Insert copied row based on cell value
Sub BlankLine()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "DQ"
StartRow = 3
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) <> "" Then
.Cells(R, Col).EntireRow.Copy
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
.Cells(R, Col).EntireRow.Interior.ColorIndex = 4
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
Related
Input:
Output:
Sub Macro3()
'
' Macro3 Macro
'
' Keyboard Shortcut: Ctrl+t
'
j = 1
a = Worksheets("Allocation").Cells(Rows.Count, j).End(xlUp).row
For i = 2 To a
If Worksheets("Allocation").Cells(i, 2).Value > 0 Then
Worksheets("Allocation").Rows(i).Copy
Worksheets("Output").Activate
b = Worksheets("Output").Cells(Rows.Count, 1).End(xlUp).row
Worksheets("Output").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Allocation").Activate
j = j + 1
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("Allocation").Cells(1, 1).Select
End Sub
To go through your table like that, you'd need to work in two for loops, 1 for the rows and 1 for the columns.
Sub getAllOnes()
Dim lColumn As Long, lastrow As Long, lRowO As Long
Dim wsA As Worksheet, wsO As Worksheet
Dim sCopy As String
Set wsA = ActiveWorkbook.Worksheets("Allocation")
Set wsO = ActiveWorkbook.Worksheets("Output")
lRowO = 2 'start row of your Output
lastrow = wsA.Range("A" & Rows.Count).End(xlUp).Row
lColumn = wsA.Cells(1, Columns.Count).End(xlToLeft).Column
For j = 2 To lColumn 'looping through columns
For i = 2 To lastrow 'looping through your rows
If Cells(i, j).Value2 > 0 Then 'assuming you only have 1's in the table, this should suffice
wsO.Cells(lRowO, 1).Value2 = wsA.Cells(i, 1).Value2 'using values makes sure you get the value but don't need to keep switching between sheets or copying
wsO.Cells(lRowO, 2).Value2 = wsA.Cells(1, j).Value2
lRowO = lRowO + 1
End If
Next i
Next j
End Sub
This outta do it. If anything is unclear, let me know.
I need some help with comparing values from one column to another and delating it.
so far I have this:
Sub DelateDuplicates()
delArray = Sheets("Save").Range("B1:B") ' saved values
toDelate = Sheets("Validation").Range("B2:B").Value ' values to be checked and delated
lastRow = toDelate.Range("B1000").End(xlUp).Row ' last row
Firstrow = toDelate.Range("B2").End(xlDown).Row ' First row
Dim i As Long
For Lrow = lastRow To Firstrow Step -1
With Worksheets("Validation").Cells(Lrow, "A")
For i = 0 To UBound(delArray) ' arrays are indexed from zero
If Not IsError(.Value) Then
If .Value = delArray(i) Then
.EntireRow.Delete
Exit For
End If
End If
Next
End With
Next Lrow
End Sub
And I do have an error.
"1004 "Application-defined or Object-defined error" "
I have spent 2 days trying to figure it out so far no luck.
Any help will be appreciated.
I modified your code little bit. You can define your first rows and last row the want you want, I have kept it simple for the sake of concept
Option Explicit
Sub DelateDuplicates()
Dim Lrow As Long
Dim delarray()
With Worksheets("Save")
delarray = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
Dim i As Long
Dim lastrow As Long
Dim firstrow As Long
firstrow = 1
With Worksheets("Validation")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Lrow = lastrow To firstrow Step -1
For i = 1 To UBound(delarray)
If Not IsError(.Cells(Lrow, "A").Value) Then
If .Cells(Lrow, "A").Value = delarray(i, 1) Then
.Cells(Lrow, "A").EntireRow.Delete
Exit For
End If
End If
Next i
Next Lrow
End With
End Sub
You can avoid loops within loops by using a Dictionary Object
Option Explicit
Sub DeleteDuplicates()
Dim wsSave As Worksheet, wsValid As Worksheet
Dim iLastRow As Long, iFirstRow As Long, i As Long, n As Long
Dim dict As Object, key, cell As Range
With ThisWorkbook
Set wsSave = .Sheets("Save")
Set wsValid = Sheets("Validation")
End With
Set dict = CreateObject("Scripting.Dictionary")
' get values to delete from Column B
For Each cell In wsSave.Range("B1", wsSave.Cells(Rows.Count, "B").End(xlUp))
key = Trim(cell)
If Len(key) > 0 Then
dict(key) = cell.Row
End If
Next
' scan Validation sheet and delete matching from Save
With wsValid
iFirstRow = .Cells(2, "B").End(xlDown).Row
iLastRow = .Cells(Rows.Count, "B").End(xlUp).Row
For i = iLastRow To iFirstRow Step -1
key = .Cells(i, "A")
If dict.exists(key) Then
.Rows(i).Delete
n = n + 1
End If
Next
End With
' resutl
MsgBox n & " rows deleted between row " & _
iFirstRow & " and " & iLastRow, vbInformation
End Sub
I'm trying to copy all rows from between two cell values and paste the values in a new column in a new worksheet. Let's say my data is structured in one excel column as such:
x
1
2
3
y
x
4
5
6
y
So I want to copy the 123 and the 456, paste them in a new worksheet in columns A and B respectively, like so:
A B
1 1 4
2 2 5
3 3 6
The code that I have working copies the data just fine, but it only pastes them below each other. Is there any way to amend the following code to paste the copied data in a new column every time the loop runs through?
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
rownum = 1
colnum = 1
lastrow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
Do
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
rownum = rownum + 1
If (rownum > lastrow) Then Exit For
Loop Until .Cells(rownum, 1).Value = "y"
endrow = rownum - 1
rownum = rownum + 2
Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy
Sheets("Sheet2").Select
ActiveSheet.Range("A1").Select
ActiveSheet.Paste
Next rownum
End With
End Sub
There's a lot going on in that code that doesn't need to. Have a look at the below and see if you can follow what's happening:
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
colnum = 1 'start outputting to this column
Dim rangetocopy As Range
With Worksheets("Sheet1")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
If .Cells(rownum, 1).Value = "y" Or rownum = lastrow Then
endrow = rownum
Set rangetocopy = Worksheets("Sheet1").Range("A" & startrow & ":A" & endrow)
rangetocopy.Copy Sheets("Sheet2").Cells(1, colnum)
colnum = colnum + 1 ' set next output column
End If
Next rownum
End With
End Sub
you could use:
SpecialCells() method of Range object to catch "numeric" values range
Areas property of Range object to loop through each set of "numeric" range
as follows:
Sub CommandButton1_Click()
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)
Dim area As Range
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
to manage data of any format (not only "numeric") between "x"s or "x"s and "y"s, then use
AutoFilter() method of Range object to filter data between "x"s or "x"s and "ys" "
SpecialCells() method of Range object to catch not empty values range
Areas property of Range object to loop through each set of "selected" range
as follows:
Sub CommandButton1_Click()
Dim area As Range
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>x", Operator:=xlAnd, Criteria2:="<>y"
With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants) '.Offset(-1)
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
.AutoFilterMode = False
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
This type was already mentioned, but since I wrote it, I'll share it as well, using range areas.
This is also assuming layout is actual in the original question and that you are trying to extract a group of numbers.
Sub Button1_Click()
Dim sh As Worksheet, ws As Worksheet
Dim RangeArea As Range
Set sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
For Each RangeArea In sh.Columns("A").SpecialCells(xlCellTypeConstants, 1).Areas
RangeArea.Copy ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1)
Next RangeArea
End Sub
I found the code below over here: Insert row below based on cell value excel macro
It works but, like the poster in the other message, I want the new row to be inserted below the existing row (here the row with a "2" in it), rather than above. I've tried changing Shift:=xlDown to xlUp but that has no effect. What am I missing something?
Sub BlankLine()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "C"
StartRow = 1
BlankRows = 1
With ActiveSheet
For R = LastUsedRow() To StartRow + 1 Step -1
If .Cells(R, Col) = "2" Then
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
End Sub
To insert the row below R use R + 1. Is this what you are trying?
Dim R As Long, LastRow As Long
LastRow = LastUsedRow()
With ActiveSheet
For R = LastRow To 2 Step -1
If .Range("C" & R).Value = 2 Then _
.Range("C" & R + 1).EntireRow.Insert Shift:=xlDown
Next R
End With
I found a macro at Insert copied row based on cell value.
The macro inserts a blank row above any row that has a value of "0" in column E.
Instead of the empty row appearing above, I need it to appear below.
Sub BlankLine()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "E"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "0" Then
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
Edit the following line from:
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
to:
.Cells(R+1, Col).EntireRow.Insert Shift:=xlDown
Pertinent to you question, modify a single line in original code: instead of:
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
use this one:
.Cells(R, Col).EntireRow.Insert Shift:=xlUp
Rgds,