Haven't ever had to do this for an entire range, but only per cell for one column, so I need to figure out if this is even right. I want to loop through a column range (E2:S2) and if every cell is blank, then delete the whole row. If there is at least one cell in that range with data, then keep the row.
How could I edit this in order to create that For/Next loop?
Sub DeleteRowsWithEmptyColumnDCell()
Dim rng As Range
Dim i As Long
Set rng = ThisWorkbook.ActiveSheet.Range("E2:S2") ' <- and then loop to next row, etc..
With rng
For i = .Rows.Count To 1 Step -1
If .Item(i) = "" Then
.Item(i).EntireRow.Delete
End If
Next i
End With
End Sub
Would I need to add the for/next loop around the rng?
Have in mind Lastrow replace .Rows.Count. If needed, change the column for which Lastrow is calculated. For this example i use Column A.
Try:
Option Explicit
Sub DeleteRowsWithEmptyColumnDCell()
Dim rng As Range, cell As Range
Dim i As Long, y As Long, DeleteRow As Long, Lastrow As Long
Dim cellEmpty As Boolean
With ThisWorkbook.ActiveSheet
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For y = Lastrow To 2 Step -1
Set rng = .Range("E" & y & ":S" & y)
cellEmpty = False
For Each cell In rng
If cell.Value <> "" Then
cellEmpty = False
Exit For
Else:
cellEmpty = True
DeleteRow = cell.Row
End If
Next
If cellEmpty = True Then
.Rows(DeleteRow).EntireRow.Delete
End If
Next y
End With
End Sub
Related
I apologize for the vague title as I'm not really sure where the error is. I think I'm having some compability issues with copying the elements of an array and then manipulating that data.
This is the code I have so far:
Sub listNotCompletedTasks()
Dim cell As Range
Dim sourceRange As Range
Dim targetRange As Range
Dim notCompleted() As Variant
Dim i As Integer
Dim lastr As Integer
'define sourceRange
lastr = Range("A" & Rows.count).End(xlUp).Row
Set sourceRange = Range("A2:A" & lastr)
'notCompleted is an array with all the offset cells of the cells in sourceRange
'that don't contain a "Completed" string
i = 0
For Each cell In sourceRange.Cells
If cell.Offset(0, 2).Value <> "Completed" Then 'if the cell in column C does not contain "completed"...
ReDim Preserve notCompleted(0 To i)
notCompleted(i) = cell.Value 'add cell in column A to array
i = i + 1
End If
Next cell
'define targetRange
lastRow = Cells(Rows.count, "Z").End(xlUp).Row
Set targetRange = Range("Z1:Z" & lastRow)
'copy all elements from the array to the targetRange
For i = 0 To UBound(notCompleted)
targetRange.Offset(i, 0).Value = notCompleted(i)
Next i
End Sub
Expected output:
This works well. The problem begins with the second step:
Sub listNoDuplicatesAndNoOfInstances()
Dim sourceRangeZ As Range
Dim targetRangeB As Range
Set sourceRangeZ = Sheets("SourceData").Range("Z2")
Set targetRangeB = Sheets("TargetSheet").Range("B17")
'add all of the unique instances of a string in Z from the notCompleted() array
Do Until IsEmpty(sourceRangeZ)
If Application.WorksheetFunction.CountIf(Sheets("TargetSheet").Range("B:B"), sourceRangeZ.Value) = 0 Then
targetRangeB.Value = sourceRangeZ.Value
Set targetRangeB = targetRangeB.Offset(1, 0)
Else
End If
Set sourceRangeZ = sourceRangeZ.Offset(1, 0)
Loop
'count every instance of those strings and add the value to the respective cell to the right
Set targetRangeB = Sheets("TargetSheet").Range("C17")
Do Until IsEmpty(targetRangeB.Offset(0, -1))
targetRangeB.Formula = "=COUNTIF(SourceData!Z:Z,Z" & targetRangeB.Row & ")"
Set targetRangeB = targetRangeB.Offset(2, 0)
Loop
End Sub
The first loop (the one that adds every unique instance of the strings to column B) works. The second loop (the one that returns the number of instances of each string) does not work, only returning zeroes. The thing is, if I manually do the steps of the first subroutine (use a Pivot Table to filter out the rows I need, then copy the relevant row and paste it to column Z), and then call the second subroutine, then it actually works!
So I'm assuming the first subroutine is the culprit. A "cheap" workaround that worked for me was to copy the range in Z to another column (using sourceRange.Copy/targetRange.PasteSpecial xlPasteAll) and then call the second subroutine. What am I doing wrong, and is there a better way to solve this?
A 2D array you can copy to sheet without looping.
Sub listNotCompletedTasks()
Dim wsSource As Worksheet, arNotCompl()
Dim lastrow As Long, i As Long, n As Long
Set wsSource = ThisWorkbook.Sheets("SourceData")
With wsSource
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim arNotCompl(1 To lastrow, 1 To 1)
For i = 2 To lastrow
If .Cells(i, "C") <> "Completed" Then
n = n + 1
arNotCompl(n, 1) = .Cells(i, "A")
End If
Next
If n = 0 Then Exit Sub
'copy array to targetRange
lastrow = .Cells(.Rows.Count, "Z").End(xlUp).Row
.Cells(lastrow + 1, "Z").Resize(n) = arNotCompl
End With
End Sub
Add the formula in column C when you add the unique value to column B.
Sub listNoDuplicatesAndNoOfInstances()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lastrow As Long, i As Long, n As Long
Dim arNotCompl(), v
Set wsSource = ThisWorkbook.Sheets("SourceData")
With wsSource
lastrow = .Cells(.Rows.Count, "Z").End(xlUp).Row
arNotCompl = .Range("Z2:Z" & lastrow).Value2
End With
Set wsTarget = ThisWorkbook.Sheets("TargetSheet")
n = 17
With wsTarget
For i = 1 To UBound(arNotCompl)
v = arNotCompl(i, 1)
If Application.WorksheetFunction.CountIf(.Range("B:B"), v) = 0 Then
.Cells(n, "B") = v
.Cells(n, "C").Formula = "=COUNTIF(SourceData!Z:Z,B" & n & ")"
n = n + 1
End If
Next
End With
End Sub
I am trying to write a macro that will look in column A on sheet1 and see if it is missing any values from column A on sheet2 or column A on sheet3. If it is missing have the value added to the bottom of the column A on sheet1. The same value may exist on sheet2 and sheet3 but it only needs to be represented once on sheet1.
I'm working with the code below.
Sub newRow()
Dim rngSh1 As Range, rngSh2 As Range, rngSh3 As Range, mySelSh2 As Range, mySelSh3 As Range
Dim lastRowSh1 As Long, lastRowSh2 As Long, lastRowSh3 As Long
Dim wb As Worksheet
Dim cell As Range
Set wb = ThisWorkbook
With wb
lastRowSh1 = Worksheets("Sheet1").Range("A" & .Rows.Count).End(xlUp).Row
lastRowSh2 = Worksheets("Sheet2").Range("A" & .Rows.Count).End(xlUp).Row
lastRowSh3 = Worksheets("Sheet3").Range("A" & .Rows.Count).End(xlUp).Row
Set rngSh1 = Worksheets("Sheet1").Range("A1:A" & lastRowSh1)
Set rngSh2 = Worksheets("Sheet2").Range("A1:A" & lastRowSh2)
Set rngSh3 = Worksheets("Sheet3").Range("A1:A" & lastRowSh3)
End With
For Each cell In rngSh2.Cells
If IsError(Application.Match(cell.Value, rngSh1, 0)) Then
If mySelSh2 Is Nothing Then
Set mySelSh2 = cell
Else
Set mySelSh2 = Union(mySelSh2, cell)
End If
End If
Next cell
If Not mySelSh2 Is Nothing Then mySelSh2.Copy Destination:=Worksheets("Sheet1").Range("A" & lastRowSh1 + 1)
For Each cell In rngSh3.Cells
If IsError(Application.Match(cell.Value, rngSh1, 0)) Then
If mySelSh3 Is Nothing Then
Set mySelSh3 = cell
Else
Set mySelSh3 = Union(mySelSh3, cell)
End If
End If
Next cell
If Not mySelSh3 Is Nothing Then mySelSh3.Copy Destination:=Worksheets("Sheet1").Range("A" & lastRowSh1 + 1)
End Sub
I've made every adjustment I can think of but with every change I make I get a different error.
Any help would be greatly appreciated. Thanks!
Save yourself a little bit of time using a Scripting.Dictionary:
Option Explicit
Sub test()
Dim dict As New Scripting.dictionary, sheetNum As Long
For sheetNum = 2 To Sheets.Count
With Sheets(sheetNum)
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim rowNum As Long
For rowNum = 1 To lastRow
Dim dictVal As Long: dictVal = .Cells(rowNum, 1).Value
If Not dict.Exists(dictVal) Then dict.Add dictVal, 0
Next rowNum
End With
Next sheetNum
With Sheets(1)
Dim checkableRangeLastRow As Long: checkableRangeLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim checkableRange As Range: Set checkableRange = .Range(.Cells(1, 1), .Cells(checkableRangeLastRow, 1))
Dim dictKey As Variant
For Each dictKey In dict.Keys
If IsError(Application.Match(dictKey, checkableRange, 0)) = True Then
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(lastRow + 1, 1).Value = dictKey
End If
Next dictKey
End With
End Sub
You add all values in your not-master-sheet into dict then loop through that list; if it's not found in your master-sheet, then you add then to the end of the list.
A significant note is that the Type of value used as the dictVal may cause the IsError() statement to always be True if it is not the same Type as the data being assessed in the checkableRange.
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 transfer data from one sheet to another.
My sheet1 is "form" type sheet. I have command button in it.
On pressing of command button cell value should be copied to another Sheet2.
I want every copy of value should be in one row and fixed column.
It should not be overwrite but enter in next empty row.
I am using below VBA code:
Private Sub Button1_Click()
Dim rng As Range
Set rng = Sheets("Sheet1").Range("A1,A2,B1,B2,B3")
For Each cell In rng
'here you copy to another sheet, one row lower
Sheets("Sheet2").Cells(cell.Row + 1, cell.Column).Value = cell.Value
Next cell
For x = lRow To 2 Step -1
If Range("I" & x) <> vbNullString Then Range("I" & x).EntireRow.Delete
Next x
Application.CutCopyMode = False
End Sub
Option Explicit
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim LastRow As Long, i As Long
Dim str As String, chara As Variant
Dim rng As Range, cell As Range
With ThisWorkbook
Set ws1 = .Worksheets("Sheet1") '<- Set worksheet ws1
Set ws2 = .Worksheets("Sheet2") '<- Set worksheet ws2
End With
Set rng = ws1.Range("B1:D1,B2:B6,B8:E11") '<- Set the range you want to loop
For Each cell In rng
If str = "" Then '<- Create a string with all details
Else
str = str & "," & cell.Value
End If
Next cell
LastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
i = 1
For Each chara In Split(str, ",") '<- Split with commas
ws2.Cells(LastRow + 1, i) = chara
i = i + 1
Next chara
End Sub
I have a sheet containing data. I want to delete the columns based on row value.
My code doesn't stop and when I hit escape, it has deleted all of the column from my starting columns.
I want to check values in row 2 from column D to the last used column (I have about 100 columns now) that if they contain C15, C17 and so on then don't do anything, else, delete the columns.
I only have 40k rows. My range, column and row will expand every week so I want to use VBA to cut down formatting time.
Sub test()
'start
Dim LR1 As Long
Dim i As Long
Set ws = ThisWorkbook.ActiveSheet
With ws
LR1 = .Cells(2, .Columns.Count).End(xlToLeft).Column
Dim arr As Variant
Dim x
arr = Array("C15", "C17", "C19", "C20", "C21", "C22", "C23", "C24", "C25", "C28", "C29", "C30", "C32")
For x = LBound(arr) To UBound(arr)
For i = LR1 To 4 Step -1
If .Cells(2, i).Value = arr(x) Then
Else
.Columns(i).Delete
End If
Next i
Next x
End With
End Sub
Besides all the points made in the comments, the main issue is that your looping logic is off. Your outer loop should be the columns, and the inner loop should be the array. But with Select Case this can be simplified this to just one loop anyway.
Perhaps something like this:
Option Explicit
Sub Test()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
With ws
Dim lastCol As Long, i As Long
Dim rng As Range
lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
For i = lastCol To 4 Step -1
Select Case .Cells(2, i).Value
Case "C15", "C17", "C19", "C20", "C21", "C22", "C23", "C24", "C25", "C28", "C29", "C30", "C32"
' keep
Case Else
If rng Is Nothing Then
Set rng = .Columns(i)
Else
Set rng = Union(rng, .Columns(i))
End If
End Select
Next i
If Not rng Is Nothing Then
rng.Delete
End If
End With
End Sub