I have an Excel sheet which is pulled from JIRA. This sheet has variable rows each week. Once it is pulled, I have a macro which performs various actions. One of these is to move certain rows to bottom of the sheet based on a value present in Column 'F'. In this particular case, if the value 'RCR' is present in column 'F', then that particular row should cut and paste at the bottom.
For this I have written the below code. This code works well and does the job. But the issue is since it loops from bottom to top, the list of rows with 'RCR' values is in a descending manner. But I want the rows to be sorted in an ascending manner.
If I use "1 to lastRowOne" in the For loop, then what happens is the row gets deleted after the move has been done, due to this, if the next row also has the value of 'RCR', that particular row is skipped because it takes the place of the deleted row. So the macro moves to the row after that, which is causing the macro to miss certains rows having consecutive value = 'RCR'.
Dim wsOne As Worksheet
Dim lastRowOne As Long
Dim lastRowTwo As Long
Set wsOne = ActiveWorkbook.Sheets("Status")
lastRowOne = wsOne.Cells(wsOne.Rows.Count, 1).End(xlUp).Row
lastRowTwo = wsOne.Cells(wsOne.Rows.Count, 1).End(xlUp).Row + 1
For I = lastRowOne To 1 Step -1
If wsOne.Range("F" & I).Value = "RCR" Then
wsOne.Rows(lastRowTwo).Value = wsOne.Rows(I).Value
wsOne.Rows(I).EntireRow.Delete
End If
Next
Is there a way that this can be remedied?
Use Union() to make a non-contiguous range, copy that range and then delete afterwards.
Dim wsOne As Worksheet
Dim lastRowOne As Long
Dim i As Long
Dim rng As Range
Set wsOne = ActiveWorkbook.Sheets("Status")
lastRowOne = wsOne.Cells(wsOne.Rows.Count, 1).End(xlUp).Row
With wsOne
For i = 1 To lastRowOne
If wsOne.Range("F" & i).Value = "RCR" Then
If rng Is Nothing Then
Set rng = .Rows(i)
Else
Set rng = Union(rng, .Rows(i))
End If
End If
Next
rng.Copy .Range("A" & lastRowOne + 1)
rng.Delete
End With
Related
A pivot table has been created and I need a macro that can pick up the Pivot body data, with no filters, from a specified worksheet (Pivot1) and copy the results into another sheet (Selection) on the next blank cell.
I've used and modified the below, which I found on this site, however its not picking up my sheets and I get a runtime error '424'
Any ideas on how this can be executed?
Sub PastePivot()
Dim i As Long
Dim LR As Long
Dim j As Long
Dim c As Long
'Find last used row in Pivot1
LR = Pivot1.Cells(Pivot1.Rows.Count, 1).End(xlUp).Row
'Find last used row in Selection
j = Selection.Cells(Selection.Rows.Count, 1).End(xlUp).Row
'Loop through rows on Pivot1
For i = 3 To LR
'Decide whether to copy the row or not
If Pivot1.Cells(i, 1).Value <> "0" Then
'Update pointer to the next unused row in Selection
j = j + 1
'Only copy used columns, to stop it thinking every cell in the
'destination row is "used"
c = Pivot1.Cells(i, Pivot1.Columns.Count).End(xlToLeft).Column
'Copy the values (without using Copy/Paste via the clipboard)
Selection.Rows(j).Resize(1, c).Value = Pivot1.Rows(i).Resize(1, c).Value
End If
Next i
End Sub
If you want to get the body of a pivot table use it's DataBodyRange property.
The below code assumes you have 1 pivot table on 'Sheet1' and you want to copy it to 'Sheet2'.
Sub CopyPivotBody()
Dim ws As Worksheet
Dim pt As PivotTable
Dim rngBody As Range
Set ws = Sheets("Sheet1")
Set pt = ws.PivotTables(1)
Set rngBody = pt.DataBodyRange
rngBody.Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End Sub
Note, if that doesn't give you the exact range you want you can offset/resize it like any other range.
I have a worksheet of data that has four columns. I want the spreadsheet to add 3 rows after each group based on column D. Column D has the department for the transactions. All department transactions are listed in a row. So Excel just needs to find the change in department and enter three rows after that section.
I have tried this code I found here. It puts a row after every line it sees the department in.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("IMPORT-WIP") 'better define by name: ThisWorkbook.Worksheets("MySheet")
Dim LastRow_f As Long
LastRow_f = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
ws.Range("A1:D" & LastRow_f).AutoFilter Field:=12, Criteria1:="HR DEPARTMENT"
Dim FilteredData As Range
Set FilteredData = ws.Range("D2:D" & LastRow_f).SpecialCells(xlCellTypeVisible)
Dim iArea As Long
Dim iRow As Long
For iArea = FilteredData.Areas.Count To 1 Step -1 'loop from last to first area
For iRow = FilteredData.Areas(iArea).Rows.Count To 1 Step -1 'loop from last row to first row in each area
With FilteredData.Areas(iArea).Rows(iRow) '<-- this represents the current row we are in the loop
.Offset(RowOffset:=1).EntireRow.Insert Shift:=xlDown
.Offset(RowOffset:=1).EntireRow.Interior.Color = RGB(192, 192, 192)
End With
Next iRow
Next iArea
'remove filters
ws.Range("A1:D" & LastRow_f).AutoFilter
This code will insert 3 rows between groups of values (even unique values). The data does not need to be filtered. It will loop through Column D, test the cell above the current cell and, if not the same value, will insert 3 rows between them. You may have to sort the data first, depending on what you want.
Sub InsertRowsBetweenGroups()
Dim ws As Worksheet, lr As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change as needed
lr = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
For i = lr - 1 To 2 Step -1
If Cells(i, "D") <> Cells(i - 1, "D") Then
Cells(i, "D").Resize(3).EntireRow.Insert Shift:=xlDown
End If
Next i
End Sub
I'm trying to loop through my data and Union certain row numbers that I need to delete later on. The code below stores the correct rows, but I can't delete them. I believe it's because my data is arranged in a table, since I'm able to delete the desired rows if the data is not in a table. I get the error message 'run time error 1004 - delete method of range class failed' on the line Urng.delete.
Sub DeleteRows()
Dim ws4 As Worksheet: Set ws4 = Worksheets("Sheet1")
Dim LastRow As Long
Dim CurrentRow As Long
Dim GroupValue
Dim GroupTotal As Long
Dim x As Long
Dim Urng As Range
Application.ScreenUpdating = False
ws4.Activate
GroupValue = ws4.Range("B6").Value
CurrentRow = 6 LastRow = ws4.Cells(Rows.Count, "B").End(xlUp).Row
Set Urng = Rows(LastRow + 1)
For x = 1 To LastRow
GroupTotal = Application.WorksheetFunction.CountIf(Range("B6:B" & LastRow), GroupValue)
If GroupTotal = 1 Then
Set Urng = Union(Urng, Rows(CurrentRow))
End If
CurrentRow = CurrentRow + GroupTotal
GroupValue = Range("B" & CurrentRow).Value
If GroupValue = "" Then '
Exit For
End If
Next x
Urng.Delete
Application.ScreenUpdating = True
End Sub
I've tried using .EntireRow.Delete without luck.
There's no data outside the table, so deleting just the table rows could be a solution, however, I don't know how to build the loop that Unions the row numbers if I can't use the row number in Union(Urng, Rows(CurrentRow)).
Is there a VBA-solution to delete multiple entire rows, where part of the row is a table?
This is how to delete row number 5 from a table named TableName:
Sub TestMe()
Range("TableName[#All]").ListObject.ListRows(5).Delete
End Sub
Concerning your specific problem, the case is that in Urng you are having rows, which are both in and outside the table. Thus, they cannot be deleted with .Delete. Write this before Urng.Delete to see yourself:
Urng.Select
Stop
Unrg.Delete
At the sample you may see that the row 6 is in the table and row 18 is outside the table:
Concerning deletion of two rows, which are not close to each other in a table, I guess that the only way is to loop. It is a bit slower indeed, but it works:
Sub TestMe()
Dim cnt As Long
Dim arrRows As Variant: arrRows = Array(10, 12)
Dim table As ListObject: Set table = ActiveSheet.ListObjects("SomeTable")
For cnt = UBound(arrRows) To LBound(arrRows) Step -1
table.ListRows(arrRows(cnt)).Delete
Next cnt
'This works only when the rows are after each other, e.g. 2,3,4
table.Range.Rows("2:4").Select
Stop
table.Range.Rows("2:4").Delete
End Sub
I have one excel sheet (lets say sheet A) that has data in it, organized into groupings separated by an empty row and grouped by a common entry in column N. Within each grouping, I need to check another excel sheet (lets say sheet B) in a different workbook to see if any of the entries in column A of sheet A matches any entries in sheet B's column C. If any of the column C entries match those of the column A entries in a single grouping of the first sheet, I do not do anything to that grouping. If there are no matches, I need to delete the whole grouping. Below is my attempt, but I am mostly getting confused with 1. how to delete just a grouping and 2. how to call to each sheet/column correctly.
Sub DeleteAdjacent()
Dim wb1 As Workbook, Dim wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
Dim lastrow1 As Long, Dim lastrow2 As Long, Dim i As Long, Dim j As Long
Set wb1 = Workbooks("Workbook1.xlsx")
Set wb2 = Workbooks("Workbook2.xlsx")
Set sh2 = wb2.Sheets(“Sheet B”)
Set sh1 = wb1.Sheets("Sheet A")
lastrow1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
For j = lastrow1 To 1 Step -1
cell = "N" & j
cell1 = "N" & (j - 1)
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
For i = lastrow2 To 1 Step -1
cell2 = "C" & i
cell3 = "A" & j
If sh1.Cells(j, cell3).Value = sh2.Cells(i, cell2).Value Then
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
sh1.Range(j, cell).EntireRow.Delete
Loop
End If
Next i
Loop
Next j
End Sub
Edit: Looking at my attempt more closely, it would actually do the opposite of what I'd want to do. I attempted to delete the entire grouping when there was a match, when I actually want the exact opposite. I think then the part below should be changed.
If sh1.Cells(j, cell3).Value = sh2.Cells(i, cell2).Value Then
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
sh1.Range.Cells(j, cell).EntireRow.Delete
Loop
End If
My attempt at correcting this is maybe too simple?
If sh1.Cells(j, cell3).Value <> sh2.Cells(i, cell2).Value Then
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
sh1.Range.Cells(j, cell).EntireRow.Delete
Loop
End If
I think if I were attacking this problem I wouldn't compare A with C and do the group looping check in the same process. It might be easier to get your head around the issue if you create a map of values to groups first. Say a value of 10 exists in groups 1,3 and 5, then you could just check for a 10 and immediately eliminate 3 groups from your future checks. A Collection of Collections would serve you well for this as the look up by key is very fast and you don't have to worry about the number of items it stores.
If you also had a collection of Ranges for each group then it would be a simple process of eliminating matching groups and then, in one hit, delete all the remaining Ranges.
The code below should do that for you (but as with any row delete code, I'd suggest you back up your raw data first!):
Public Sub DeleteAdjacent()
Dim ws As Worksheet
Dim valueGroupMap As Collection
Dim groupRanges As Collection
Dim values As Collection
Dim lastRow As Long
Dim groupRng As Range
Dim valueCell As Range
Dim groupCell As Range
Dim rng As Range
Dim v As Variant
Dim r As Long
'Read the Column A worksheet
Set ws = Workbooks("Workbook1.xlsx").Worksheets("Sheet A")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1 '+1 to get a blank row at end
'Define the value map group ranges
Set valueGroupMap = New Collection
Set groupRanges = New Collection
Set groupRng = ws.Cells(1, "N")
For r = 1 To lastRow
Set valueCell = ws.Cells(r, "A")
Set groupCell = ws.Cells(r, "N")
If Len(CStr(groupCell.Value2)) = 0 Then
'We've reached the end of a group
Set rng = ws.Range(groupRng, groupCell.Offset(-1))
groupRanges.Add rng, CStr(groupRng.Value2)
Set groupRng = Nothing
Else
'We're working within a group
If groupRng Is Nothing Then
Set groupRng = groupCell
End If
'Create the value to group map
Set values = Nothing
On Error Resume Next
Set values = valueGroupMap(CStr(valueCell.Value2))
On Error GoTo 0
If values Is Nothing Then
Set values = New Collection
valueGroupMap.Add values, CStr(valueCell.Value2)
End If
values.Add CStr(groupRng.Value2)
End If
Next
'Read the Column C worksheet
Set ws = Workbooks("Workbook2.xlsx").Worksheets("Sheet B")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
For r = 1 To lastRow
'Check if we have the value
Set values = Nothing
Set values = valueGroupMap(CStr(ws.Cells(r, "C").Value2))
If Not values Is Nothing Then
'We do, so remove the group ranges from our list
For Each v In values
groupRanges.Remove CStr(v)
Next
End If
Next
On Error GoTo 0
'Create a range of the groups still remaining in the list
Set rng = Nothing
For Each groupRng In groupRanges
If rng Is Nothing Then
Set rng = groupRng
Else
Set rng = Union(rng, groupRng)
End If
Next
'Delete that range
rng.EntireRow.Delete
End Sub
This is my first attempt at VBA, so I apologize for my ignorance. The situation is as follows: I have a spreadsheet that consists of 4 columns and 629 rows. When I am trying to do is iterate through the 4 cells in each row and check for a blank cell. If there is a row that contains a blank cell, I want to cut it from Sheet1 and paste it into the first available row in Sheet2.
(Ideally the number of columns AND the number of rows is dynamic based on each spreadsheet, but I have no idea how to iterate through rows and columns dynamically)
Sub Macro1()
'
' Macro1 Macro
' Move lines containing empty cells to sheet 2
'
' Keyboard Shortcut: Ctrl+r
'
Dim Continue As Boolean
Dim FirstRow As Long
Dim CurrentRow As Long
Dim LastRow As Long
Dim EmptySheetCount As Long
Dim Counter As Integer
'Initialize Variables
LContinue = True
FirstRow = 2
CurrentRow = FirstRow
LastRow = 629
EmptySheetCount = 1
'Sheets(Sheet1).Select
'Iterate through cells in each row until an empty one is found
While (CurrentRow <= LastRow)
For Counter = 1 To 4
If Sheet1.Cells(CurrentRow, Counter).Value = "" Then
Sheet1.Cells(CurrentRow).EntireRow.Cut Sheet2.Cells(EmptySheetCount, "A")
EmptySheetCount = EmptySheetCount + 1
Counter = 1
CurrentRow = CurrentRow + 1
GoTo BREAK
Else
Counter = Counter + 1
End If
Counter = 1
BREAK:
Next
Wend
End Sub
When I run it, I typically get an error around the Sheet1.Cells(CurrentRow, Counter).Value = "" area, so I know I'm referencing sheets incorrectly. I've tried Sheets(Sheet1), Worksheets("Sheet1") and nothing seems to be working. When I do change to Worksheets("Sheet1"), however, it runs and just freezes Excel.
I know I'm doing multiple things wrong, I just know way too little to know what.
Thanks a lot in advance. And sorry for the crap formatting.
There are a few things wrong with your code so rather than go through them individually here is a basic looping version that does what you're after.
Sub moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Dim lastColumn As Integer
Dim lastRow As Integer
Dim destinationRow As Integer
Set wksData = Worksheets("Sheet1")
Set wksDestination = Worksheets("Sheet2")
destinationRow = 1
lastColumn = wksData.Range("XFD1").End(xlToLeft).Column
lastRow = wksData.Range("A1048576").End(xlUp).Row
For i = lastRow To 1 Step -1 'go 'up' the worksheet to handle 'deletes'
For j = 1 To lastColumn
If wksData.Cells(i, j).Value = "" Then 'check for a blank cell in the current row
'if there is a blank, cut the row
wksData.Activate
wksData.Range(Cells(i, 1), Cells(i, lastColumn)).Cut
wksDestination.Activate
wksDestination.Range(Cells(destinationRow, 1), Cells(destinationRow, lastColumn)).Select
ActiveSheet.Paste
'If required this code will delete the 'cut' row
wksData.Rows(i).Delete shift:=xlUp
'increment the output row
destinationRow = destinationRow + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next j
Next i
set wksData = Nothing
set wksDestination = Nothing
End Sub
There are other ways that will achieve the same outcome but this should give you and idea of how to use loops, sheets, ranges, etc.
The lastColumn and lastRow variables will find the the last column/row of data in the given columns/rows (i.e, in my code it finds the last column of data in row 1, and the last row of data in column A).
Also, you should get into the habit of debugging and stepping through code to identify errors and see exactly what each line is doing (this will also help you learn too).
You might find this of use.
It uses an array variable to store the values of the cells in the row to be moved. It does not use cut and paste, so only transfer the data values, and the code does not require activation of the required sheets.
The destination rows are in the same order as the rows on the original sheet.
The method used to find the last cell used in the row and column is more elegant than other answers given.
Option Explicit
Public Sub test_moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Set wksData = shtSheet1 ' Use the Codename "shtSheet1" for the worksheet. ie the value of the sheet property that is displayed as "(Name)"
Set wksDestination = shtSheet2
moveData wksData, wksDestination
End Sub
Public Sub moveData(wksData As Worksheet, wksDestination As Worksheet)
Dim ilastColumn As Integer
Dim ilastRow As Integer
Dim iRow As Long
Dim iColumn As Long
Dim iDestinationRowNumber As Integer
Dim MyArray() As Variant
Dim rngRowsToDelete As Range
iDestinationRowNumber = 1
ilastColumn = wksData.Cells(1, wksData.Columns.Count).End(xlToLeft).Column
ilastRow = wksData.Cells(wksData.Rows.Count, 1).End(xlUp).Row
ReDim MyArray(1, ilastColumn)
Set rngRowsToDelete = Nothing
For iRow = 1 To ilastRow Step 1 'No need to go 'up' the worksheet to handle 'deletes'
For iColumn = 1 To ilastColumn
If wksData.Cells(iRow, iColumn).Value = "" Then 'check for a blank cell in the current row
MyArray = wksData.Range(wksData.Cells(iRow, 1), wksData.Cells(iRow, ilastColumn)).Value
wksDestination.Range(wksDestination.Cells(iDestinationRowNumber, 1),
wksDestination.Cells(iDestinationRowNumber, ilastColumn) _
).Value = MyArray
'Store the rows to be deleted
If rngRowsToDelete Is Nothing Then
Set rngRowsToDelete = wksData.Rows(iRow)
Else
Set rngRowsToDelete = Union(rngRowsToDelete, wksData.Rows(iRow))
End If
'increment the output row
iDestinationRowNumber = iDestinationRowNumber + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next iColumn
Next iRow
If Not rngRowsToDelete Is Nothing Then
rngRowsToDelete.EntireRow.Delete shift:=xlUp
End If
Set rngRowsToDelete = Nothing
Set wksData = Nothing
Set wksDestination = Nothing
End Sub
' enjoy