I want to merge cells when the cells on the right is empty. My header starts at row 31. However, I faced a run time error 13 in the line "If ActiveSheet.Range(Cells(31, 1), Cells(31, i)).Value = "" Then"
Sub mergingcells()
Dim LastCellinArow As Long
LastCellinArow = Cells(31, Columns.Count).End(xlToLeft).Column
Debug.Print (LastCellinArow)
For i = 1 To LastCellinArow
If ActiveSheet.Range(Cells(31, 1), Cells(31, i)).Value = "" Then
Range("A31:AB31").Offset(-1, 0).Merge
End If
Next i
End Sub
For example, if column j cells in row 31 is empty, I want to merge with column i cells in row 31.
please be sure that merged cells are same format. You may not merge cell with date format and cell with currency format
Please, try the next code:
Sub mergingcells()
Dim LastCellinArow As Long, i As Long
LastCellinArow = cells(31, Columns.count).End(xlToLeft).Column
Debug.Print (LastCellinArow)
For i = 2 To LastCellinArow 'starting from 2 makes more sense...
If WorksheetFunction.CountA(ActiveSheet.Range(cells(31, 1), cells(31, i))) = 0 Then
Range(cells(31, 1), cells(31, i)).merge 'it merges the left cell(s) with the next empty one
End If
Next i
End Sub
Related
I Have 10 columns in an Excel table, and I want to delete the rows where the first 7 cell is empty.
I've tried to do it this way:
Sheet1.Range("Table4[variable1, variable2, variable3, variable4, variable5, variable6, variable7]").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
but It doesn't work. Am I have to use nested for loop for rows and columns?
You can loop trough each row directly, and check if the first 7 cells of that row in your table are empty. If true, delete them.
Dim MyTable As ListObject
Dim i As Long
Set MyTable = ActiveSheet.ListObjects("Table4")
With MyTable.DataBodyRange
For i = .Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountBlank(.Range(Cells(i, 1), Cells(i, 7))) = 7 Then .Rows(i).Delete
Next i
End With
The good point about this way is that if your table changes address, it still will work. You would only need to update if you want to check a different name of cells (seven rght now) or if the condition (7 first cells empty) changes.
Broadly speaking yes. Loop down the rows you want to check,
For rowcounter = 1 to 10 'whatever rows you want
use the test
If Application.WorksheetFunction.CountA("A" & rowcounter & ":G" & rowcounter) = 0 Then
(I assume first 7 columns meant A to G), and then
Rows(rowcounter).Delete
You don't need multiple loops. A single loop with the use of the IsEmpty() function should work:
Option Explicit
Sub Test()
Dim i As Long
For i = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row To 1 Step -1
If IsEmpty(Sheet1.Cells(i,1)) And IsEmpty(Sheet1.Cells(i,2)) And IsEmpty(Sheet1.Cells(1,3)) And _
IsEmpty(Sheet1.Cells(i,4)) And IsEmpty(Sheet1.Cells(i,5)) And _
IsEmpty(Sheet1.Cells(i,6)) And IsEmpty(Sheet1.Cells(i,7)) Then
Sheet1.Rows(i).Delete
End If
Next i
End Sub
I guess that this simple snippet, full of unnecessary procedures, can help you:
Sub NotTested()
' Choose below the rows range
first_row = 2
last_row = 4242
For r = last_row To first_row Step -1
' Checking below each column (from row r) value
a_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 1).Value2
b_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 2).Value2
c_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 3).Value2
d_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 4).Value2
e_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 5).Value2
f_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 6).Value2
g_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 7).Value2
' Comparing if the columns are actually empty
If a_value = "" And b_value = "" And c_value = "" And d_value = "" And e_value = "" And f_value = "" And g_value = "" Then
ThisWorkbook.Sheets("Sheet1").Cells(r, 1).EntireRow.Delete
End If
Next r
End Sub
Here's a simple solution that actually counts the number of rows in a table then deletes if the first 7 columns are blank.
Sub deleteEmptyRows()
Set tbl = ActiveSheet.ListObjects("Table4")
For I = 1 To tbl.Range.Rows.Count
If WorksheetFunction.CountA(Range("A" & I & ":" & "G" & I)) = 0 Then
Sheets("Sheet1").Rows(I).EntireRow.Delete
End If
Next I
End Sub
I am trying to make a loop that prints every value between two cells in a row into a single column. I would also like it to skip/ignore non integer values.
For example: Cell A5 contains 5673 and Cell B5 contains 5677. Therefore the macro would output 5673, 5674, 5675, 5676, and 5677.
I have found some useful examples for looping through each row and printing each value, but have not been able to combine the two.
To print each value between the two numbers:
[D1] = [A1].Value
ato = [B1].Value
[D1].DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=ato
To loop through every row:
LR = Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To LR
Cells(j, 1).Offset(0, 2).Value = ***Every cell value between Cells(j, 1) and Cells(j, 2)***
Next j
Before:
Desired after:
Try this. You can use SpecialCells to pick out the numerical cells, and Fill to produce the intervening sequences.
Sub x()
Dim rA As Range, rCell As Range
For Each rA In Columns(1).SpecialCells(xlCellTypeConstants, xlNumbers).Areas
For Each rCell In rA
Range("D" & Rows.Count).End(xlUp)(2).Value = rCell.Value
Range("D" & Rows.Count).End(xlUp).DataSeries Rowcol:=xlColumns, Step:=1, Stop:=rCell.Offset(, 1), Trend:=False
Next rCell
Next rA
End Sub
If you will always have these 2 columns, then you may use this code
for j = 1 to 2:for i = 1 to cells(rows.count,j).end(xlup).row
if isnumeric(cells(i,j)) then cells(rows.count,4).end(xlup).offset(1,0) = cells(i,j)
next:next
bear in mind that it will post everysingle number, if you need to delete duplicates, you may do it using range.removeduplicate
Loop through the range cell by cell; test for IsNumeric and Duplicate values. Note: this is just a test code, you should always add workbook and worksheet references
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To 2
If IsNumeric(Cells(i, j)) And Cells(i, j).Offset(, 1).Value <> Cells(i, j).Value Then
If IsEmpty(Cells(1, 4).Value) Then
Cells(1, 4) = Cells(i, j)
Else: Cells(Rows.Count, 4).End(xlUp).Offset(1) = Cells(i, j)
End If
End If
Next j
Next i
I am started a Invoice with Vba. I have Code to copy a range of non empty cells and paste to another sheet and it is working perfectly but I want to copy some other cells and Paste them all in a row after the last used row.
Like
"Invoice No, Date, Customer Name, Salesman Name and Total" as I can Used these to track Invoice.
Sub CopyRange()
Dim x, y(), i As Long, ii As Long
x = Sheets("Invoice").[a12:g49]
For i = 1 To UBound(x, 1)
If x(i, 1) <> "" Then
ReDim Preserve y(1 To 7, 1 To i)
For ii = 1 To 7
y(ii, i) = x(i, ii)
Next
Else: Exit For
End If
Next
With Sheets("Invoice Record")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(y, 2), 7) = Application.Transpose(y)
End With
End Sub
Could someone please help me with some code to delete all duplicate entries across multiple columns and rows. Any cell which has a duplicate value I'd like to be blank, but I do not want to delete the cell and shift all the rows up like the remove duplicates button does. I'd like code exactly like conditional formatting does to highlight cells, but I'd like to set the value to "" instead.
I'm trying to edit the macro I recorded to something like:
Columns("I:R").Select
selection.FormatConditions.AddUniqueValues
selection.FormatConditions(1).DupeUnique = xlDuplicate
selection.FormatConditions(1).Value = ""
But I'm not sure I'm on the right track
Start at the bottom and work towards the top. Take a ten-column-conditional COUNTIFS function of the cell values while shortening the rows examined by 1 every loop.
Sub clearDupes()
Dim rw As Long
With Worksheets("Sheet1")
If .AutoFilterMode Then .AutoFilterMode = False
With Intersect(.Range("I:R"), .UsedRange)
.Cells.Interior.Pattern = xlNone
For rw = .Rows.Count To 2 Step -1
With .Resize(rw, .Columns.Count) 'if clear both then remove this
If Application.CountIfs(.Columns(1), .Cells(rw, 1), .Columns(2), .Cells(rw, 2), _
.Columns(3), .Cells(rw, 3), .Columns(4), .Cells(rw, 4), _
.Columns(5), .Cells(rw, 5), .Columns(6), .Cells(rw, 6), _
.Columns(7), .Cells(rw, 7), .Columns(8), .Cells(rw, 8), _
.Columns(9), .Cells(rw, 9), .Columns(10), .Cells(rw, 10)) > 1 Then
'test with this
.Rows(rw).Cells.Interior.Color = vbRed
'clear values with this once it has been debugged
'.Rows(rw).Cells.ClearContents
End If
End With 'if clear both then remove this
Next rw
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
I've left some code in that only marks the potential duplicates. When you are happy with the results, change that to the commented code that actually clear the cell contents.
Using two sets of nested loops I check each cell in the range twice, once to see if it was a duplicate and to mark it and a second time to then remove the value (ensuring I remove all duplicates and do not leave one instance of each duplicate).
I'm sure that this is an inefficient way of doing it but it works so hopefully helps someone else in the same boat.
Private Sub CommandButton1_Click()
Dim Row As Integer
Dim Column As Integer
Row = 100
Column = 10
'loop through identifying the duplicated by setting colour to blue
For i = 1 To Row 'loops each row up to row count
For j = 1 To Column 'loops every column in each cell
If Application.CountIf(Range(Cells(4, 1), Cells(Row, Column)), Cells(i, j)) > 1 Then 'check each cell against entire range to see if it occurs more than once
Cells(i, j).Interior.Color = vbBlue 'if it does sets it to blue
End If
Next j
Next i
'loop through a second time removing the values in blue (duplicate) cells
For i = 1 To Row 'loops each row up to row count
For j = 1 To Column 'loops every column in each cell
If Cells(i, j).Interior.Color = vbBlue Then 'checks if cell is blue (i.e duplicate from last time)
Cells(i, j) = "" 'sets it to blank
Cells(i, j).Interior.Color = xlNone 'changes colour back to no fill
End If
Next j
Next i
End Sub
Use conditional format to highlight duplicates and then change the value to "" using a loop through selection.
This code will allow one value to remain.(if you have 25 twice, this code will keep one 25)
Option Explicit
Sub DupRem()
Application.ScreenUpdating = False
Dim rn As Range
Dim dup As Range
Columns("I:R").FormatConditions.AddUniqueValues
Columns("I:R").FormatConditions(1).DupeUnique = xlDuplicate
Columns("I:R").FormatConditions(1).Font.Color = RGB(255, 255, 0)
For Each rn In Columns("I:R").Cells
If rn <> "" Then
If rn.DisplayFormat.Font.Color = RGB(255, 255, 0) Then
If dup Is Nothing Then
Set dup = rn
Else
Set dup = Union(dup, rn)
End If
End If
End If
Next
dup.ClearContents
Columns("I:R").FormatConditions(1).StopIfTrue = False
Columns("I:R").FormatConditions.Delete
Application.ScreenUpdating = True
End Sub
Okay so here is the table set up I'm working with:
I need a macro to remove the rows containing four 0's, the only way I can think of at the moment requires the cells to be empty, i.e. ""
Does 0 actually count as a string or digit or is it equivalent to "" ?
I think the problem might be related to the fact that some of my 0's are text strings and others are numbers, I just didn't think this would matter.
Try this small macro.....it examines the sum of the section of each row:
Sub RowKiller()
Dim N As Long, i As Long, wf As WorksheetFunction
Dim rng As Range
N = Cells(Rows.Count, "A").End(xlUp).Row
Set wf = Application.WorksheetFunction
For i = N To 2 Step -1
Set rng = Range(Cells(i, 1), Cells(i, 4))
If wf.Sum(rng) = 0 Then
rng.EntireRow.Delete
End If
Next i
End Sub
Here, I got one for you. Try with this.
Public Sub removeRow()
Dim row As Integer
'Set the start row.
row = 1
'Loop all row from sheet until colum "A" cell is blank
Do While Sheets("sheetname").Range("A" & row) <> ""
'If all cell are 0.
If Sheets("sheetname").Range("A" & row) = 0 And Sheets("sheetname").Range("B" & row) = 0 And Sheets("sheetname").Range("C" & row) = 0 And Sheets("sheetname").Range("D" & row) = 0 Then
'Delete entire row
Sheets("sheetname").Range("A" & row).EntireRow.Delete
Else
'Increse row
row = row + 1
End If
Loop
End Sub
Create a string of rows to delete then do ONE delete. No need to poll backwards when you do it this way and it should be a LOT faster than deleting row by row:
Sub DeleteRows()
Dim i As Long, DelRange As String
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row 'Doesn't matter which way you go when you delete in one go
If CLng(Cells(i, 1)) = 0 And CLng(Cells(i, 2)) = 0 And CLng(Cells(i, 3)) = 0 And CLng(Cells(i, 4)) = 0 Then DelRange = DelRange & "," & i & ":" & i
Next i
Range(Right(DelRange, Len(DelRange) - 1)).Delete
End Sub
Used CLng to convert the string zero to a Long zero for the test.
A small word of warning though, CLng(activecell) will return 0 if the activecell is blank so blank rows will be deleted also.
Edit: Put in a IsNumeric test to counter errors when strings are encountered (Can't CLng a true string)
Sub DeleteRows()
Dim i As Long, DelRange As String
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row 'Doesn't matter which way you go when you delete in one go
If IsNumeric(Cells(i, 1)) And IsNumeric(Cells(i, 2)) And IsNumeric(Cells(i, 3)) And IsNumeric(Cells(i, 4)) Then
If CLng(Cells(i, 1)) = 0 And CLng(Cells(i, 2)) = 0 And CLng(Cells(i, 3)) = 0 And CLng(Cells(i, 4)) = 0 Then DelRange = DelRange & "," & i & ":" & i
End If
Next i
Range(Right(DelRange, Len(DelRange) - 1)).Delete
End Sub