I have been trying to copy the first highlighted row of each new data after empty row and i have looked around to find a way which could do this but cannot find.
I can do this manually by putting name of rows to copy but code should be dynamic because rows order can be changed but there must be empty rows after new data.
Any help will be appreciated.
after copying and pasting the result would be like this.
My try
Sub copynextfirstrow()
lastRow = Sheets("Sheet1").Cells(.Rows.Count, "A").End(xlUp).Row
Sheets("Sheet1").Range("A1:A" & lastRow).Copy
Sheets("Sheet2").Range("A1").Cells.PasteSpecial
End Sub
Try the next code, please:
Sub copynextfirstrow()
Dim sh1 As Worksheet, sh2 As Worksheet, lastRow As Long, i As Long, rngCopy As Range
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
lastRow = sh1.cells(sh1.rows.count, "A").End(xlUp).row
For i = 1 To lastRow
If WorksheetFunction.CountA(sh1.rows(i)) = 0 And WorksheetFunction.CountA(sh1.rows(i + 1)) > 0 Then
If rngCopy Is Nothing Then
Set rngCopy = sh1.rows(i + 1)
Else
Set rngCopy = Union(rngCopy, sh1.rows(i + 1))
End If
ElseIf i = 1 And WorksheetFunction.CountA(sh1.rows(i)) > 0 Then
Set rngCopy = sh1.rows(i)
End If
If Not rngCopy Is Nothing Then
rngCopy.Copy
sh2.Range("A1").cells.PasteSpecial
End If
End Sub
It should be fast enough, firstly making a Union of the rows to be copied and pasting all the range at once.
I couldn't understand that an empty row is one having only a cell in A:A empty, so I created a piece of code which considers an empty row the one not having any record on all columns...
Quick example: search for blank cells and see if offset values exist:
Sub Blah()
Dim Cell As Range
Dim rng As Range
Set rng = Application.Intersect(Sheets("Sheet1").UsedRange, Sheets("Sheet1").Range("A:A")).SpecialCells(xlCellTypeBlanks)
For Each Cell In rng
If Cell.Offset(1, 0) <> "" Then Debug.Print Cell.Offset(1, 0)
Next Cell
End Sub
Related
I have been trying to create a function which checks that if Col"B" <> Empty then copy the third cell which is under the same row.
I have this Data:
Where from i want to copy the Col"D" highlighted cells and paste them into same row where Col"B" <> empty.
Here is the final result. Your help will be appreciated in this regards.
Option Explicit
Sub CopyPasting()
Dim ws As Worksheet
Dim r As Long
Dim LastRow As Long
Dim n As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
LastRow = .Range("D" & .Rows.Count).End(xlUp).Row
For r = LastRow To 2 Step -2
If .Cells(r, "B") <> "" Then
.Rows(r + "D").Copy
.Rows(r + "D").PasteSpecial
n = n + 1
End If
Next
End With
End Sub
Please, try the next code:
Sub testRetOffset3()
Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, c As Range
Set sh = ActiveSheet 'use here the sheet you need
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last sheet row
On Error Resume Next 'if not empty cells in column, it will not return the range and raise an error
Set rngV = sh.Range("B2:B" & lastR).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rngV Is Nothing Then Exit Sub 'stop the code if run on a wrong sheet, without empty cells in column B:B
For Each c In rngV.cells 'iterate between the discontinuous range cells
If rngFin Is Nothing Then 'if the final range is not set (first time)
Set rngFin = c.Offset(3, 2) 'set the range = the Offset necessary cell
Else
Set rngFin = Union(rngFin, c.Offset(3, 2)) 'make a Union between existing range and the Offset necessary cell
End If
Next
If Not rngFin Is Nothing Then 'copy both ranges in consecutive columns
rngV.Copy sh.Range("F2")
rngFin.Copy sh.Range("G2")
End If
End Sub
It will return in columns F:G, starting from the second row. It is easy to modify the range where to return...
You can even clear the existing processed columns and return in B:C, or in another sheet.
Edited:
In order to solve the last request, please use the next code:
Sub testRetOffsetMoreRows()
Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, A As Range
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
On Error Resume Next
Set rngV = sh.Range("A2:D" & lastR).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rngV Is Nothing Then Exit Sub
For Each A In rngV.Areas 'iterate between the range areas
If rngFin Is Nothing Then
Set rngFin = A.cells(1,2).Offset(3, 3) 'use the second cell of the area
Else
Set rngFin = Union(rngFin, A.cells(1,2).Offset(3, 3))
End If
Next
If Not rngFin Is Nothing Then
rngV.Copy sh.Range("H2")
rngFin.Copy sh.Range("L2")
End If
End Sub
But take care to have continuous ranges when have a value in column B:B. Otherwise, the code may fail... The areas property will return differently.
I wasn't sure where you wanted the output, this will put it into a sheet called "Sheet2". (You'll have to make that before running the code it won't create it for you.)
Dim i As Long
Dim j As Long
Dim lr As Long
Dim srcWS As Worksheet
Dim destWS As Worksheet
Set srcWS = ThisWorkbook.Sheets("Sheet1")
Set destWS = ThisWorkbook.Sheets("Sheet2")
With srcWS
lr = .Cells(.Rows.Count, 4).End(xlUp).Row
j = 2
For i = 2 To lr
If .Cells(i, 2).Value <> "" Then
destWS.Cells(j, 1).Value = .Cells(i, 2).Value
destWS.Cells(j, 2).Value = .Cells(i, 4).Offset(2, 0).Value
j = j + 1
End If
Next i
End With
If you need the colors copied over as well then use this:
.Cells(i, 4).Offset(2, 0).Copy
destWS.Cells(j, 2).PasteSpecial xlPasteAll
instead of:
destWS.Cells(j, 2).Value = .Cells(i, 4).Offset(2, 0).Value
I want to combine two separate macro's into one macro with one button.
I put some data in A1, then the first code stacks them under each other.
The second code separates them by adding a break line every 5 lines.
First macro:
Dim Rng1 As Range, Rng2 As Range, rng As Range
Dim RowIndex As Integer
Set Rng1 = Application.Selection
Set Rng1 = Application.InputBox("Select Range:", "StackDataToOneColumn",
Rng1.Address, Type:=8)
Set Rng2 = Application.InputBox("Destination
Column:", "StackDataToOneColumn", Type:=8)
RowIndex = 0
Application.ScreenUpdating = False
For Each rng In Rng1.Rows
rng.Copy
Rng2.Offset(RowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
RowIndex = RowIndex + rng.Columns.Count
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
Second macro:
Dim rng As Range
Dim CountRow As Integer
Dim i As Integer
Set rng = Selection
CountRow = rng.EntireRow.Count
For i = 1 To CountRow / 2
ActiveCell.Offset(4, 0).EntireRow.Insert
ActiveCell.Offset(5, 0).Select
Next i
End Sub
Example of data input and output:
You can do it like this:
Sub test()
'code to specify what range you want to copy
Dim MyRange As Range
Dim rng As Range
Dim i As Long
Dim ZZ As Long
Set MyRange = Range("A3").CurrentRegion 'this will be rng to be transposed
'code to positionate into target cell from sheet2
'
'
'
'in this example, my target cell will be A9, so it will be Range("A9")
i = 9
ZZ = MyRange.Cells(1, 1).Row 'top row of range
For Each rng In MyRange
If rng.Row <> ZZ Then
i = i + 1 'we add extra plus 1 so we skip 1 cell and make breakline
ZZ = rng.Row 'we update zz
End If
rng.Copy
Range("A" & i).PasteSpecial xlPasteAll
i = i + 1
Next rng
Set MyRange = Nothing
End Sub
After executing code I get:
You just need to adapt it to work on different sheets.
The trick here is detecting when you want to leave a blank cell, and it's every time you change row on your original range. So if your original range is a range of 3x5 cells, you will leave 1 blank when switching from row 1 to 2, and another one when switching from row 2 to 3.
Property rng.row will return the absolute row number, referenced to whole worksheet.
Property MyRange.Cells(1,1).Row will return the first row number of your fist top cell on your range, so you can know where it starts. With that, then you can easily track when it has switched rows when looping :)
I would like to have a macro that deletes an entire row of the cell value equals "" for multiple ranges. Ranges are "B16:B115, B131:B230, B250:B349".
Logic:
If cell equals "" then delete the entire row.
I want the row actually deleted and not just the contents of the cells.
Thank you.
This would be worth trying:
On Error Resume Next
Range("B16:B115,B131:B230,B250:B349").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error Goto 0
Depending on whether the "" cells have formulas or are just empty.
Range.SpecialCells: What does xlCellTypeBlanks actually represent?
EDIT: if you have formulas then you have to go the long way round:
Sub DeleteEmpty()
Dim c As Range, rngDel As Range
For Each c In Range("B16:B115,B131:B230,B250:B349").Cells
If Len(c.Value) = 0 Then
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(rngDel, c)
End If
End If
Next c
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub
Following sub will allow you to select range to delete blank rows.
Sub RemoveBlanks()
Dim rng As Range, rws As Long, i As Long
Dim LastRow As Range
Dim myRange As Range
Set myRange = Application.InputBox(prompt:="Select Header Cell To Remove Blanks.", Type:=8)
'LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set LastRow = Cells(Rows.Count, myRange.Column).End(xlUp)
Set rng = ActiveSheet.Range(myRange.Address & ":" & LastRow.Address)
rws = rng.Rows.Count
For i = rws To 1 Step (-1)
If WorksheetFunction.CountA(rng.Rows(i)) = 0 Then rng.Rows(i).EntireRow.Delete
Next
Set myRange = Nothing
Set LastRow = Nothing
Set rng = Nothing
End Sub
I have an excel sheet with a random amount of columns and rows (amount of columns/rows changes every time, as well as the location of each column) where I need to find a certain column with title "Course Info", and then use the CLEAN function on all rows / cells in that column (except for the title row ofcourse).
I have the code for the clean function:
Set Rng = ShData.Range("AB2:AB" & LastRow)
For Each cell In Rng
cell.Value = Application.WorksheetFunction.Clean(cell.Value)
Next cell
Problem here is that Rng is set to column AB, which isn't always that column. I have also made a LastRow & LastCol code to count the amount of rows and columns, but beyond this I'm stuck.
LastRow = ShData.Range(2, Rows.Count).End(xlUp).Row
LastCol = ShData.Range(1, Cols.Count).End(xlToLeft).Column
Use the WorksheetFunction.Match method to get the column number.
Option Explicit
Sub test()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim Col As Double
On Error Resume Next 'next line throws error if "Course Info" was not found
Col = Application.WorksheetFunction.Match("Course Info", ws.Rows(1), 0)
On Error GoTo 0 'always re-activate error reporting
If Col <> 0 Then 'only do it if "Course Info" was found
Dim Cell As Range
For Each Cell In ws.Range(ws.Cells(2, Col), ws.Cells(ws.Rows.Count, Col).End(xlUp))
Cell.Value = Application.WorksheetFunction.Clean(Cell.Value)
Next Cell
End If
End Sub
Here:
Option Explicit
Sub Test()
Dim Rng As Range, Col As Long, cell As Range, LastRow As Long, LastCol As Long
With ShData
LastRow = .Range(.Rows.Count, 2).End(xlUp).Row
LastCol = .Range(1, .Columns.Count).End(xlToLeft).Column
Col = .Rows(1).Find("Course Info").Column 'this is to find the column number
Set Rng = .Range(.Cells(2, Col), .Cells(LastRow, Col))
End With
For Each cell In Rng
cell = Application.WorksheetFunction.Clean(cell)
Next cell
End Sub
I have a working code that looks for a value and copies the entire row, pasting it to the relevant sheet.
I would like to amend the code, so that it copies the entire row above the found value, rather than the row of the value.
Can anyone suggest a simple amendment to allow me to select the row above?
Sub Prod()
Sheets("BJ").Cells.Clear
Sheets("Master").Range("A1:A2").EntireRow.Copy Destination:= _
Sheets("BJ").Range("A1")
Dim MyRange, MyRange1 As Range
Sheets("Master").Select
LastRow = Sheets("Master").Range("K65536").End(xlUp).Row
Set MyRange = Sheets("Master").Range("M1:Q325" & LastRow)
For Each c In MyRange
If c.Value = "BJ" Then
If MyRange1 Is Nothing Then
Set MyRange1 = c.EntireRow
Else
Set MyRange1 = Union(MyRange1, c.EntireRow)
End If
End If
Next
If Not MyRange1 Is Nothing Then MyRange1.Copy Sheets("BJ").[a3]
End Sub
Here is one way to copy the row directly above the ActiveCell to the next open row of another worksheet:
Sub Dural()
Dim sh2 As Worksheet, N As Long
Set sh2 = Sheets("Destynation")
N = sh2.Cells(Rows.Count, "A").End(xlUp).Row + 1
If ActiveCell.Row = 1 Then
MsgBox "Nothing above"
Exit Sub
End If
ActiveCell.Offset(-1, 0).EntireRow.Copy sh2.Cells(N, 1)
End Sub