This macro I have written searches the entire page for the values; 0, 1, 2, or 3 and then deletes that row.
Sub delRows()
Dim cl As Range
Dim uRng As Range
Dim rng As Range
Dim x As Long
Set uRng = ActiveSheet.UsedRange
For Each cl In uRng
If cl.Value = "0" Or cl.Value = "1" Or cl.Value = "2" Or cl.Value = "3" Then
If x = 0 Then
Set rng = cl
x = 1
Else: Set rng = Union(rng, cl)
End If
End If
Next cl
rng.EntireRow.Delete
End Sub
How do I change it to scan a single column for those values then delete the row?
I get errors.
Let's say I want to search in Column "J" in the worksheet?
This just requires changing one line in your code:
Set uRng = ActiveSheet.Range("J:J")
To speed things up, you can specify a smaller range, e.g. Range("J1:J100") or wherever your data is. Else you will loop through the entire column, i.e. 65536 rows (Excel 2003) or a million rows (2007 and newer), which is very time consuming.
Sub delRows2()
Application.ScreenUpdating = False
Dim r As Long, r1 As Long, r2 As Long, c As Long
c = 10 '<--- this is the column you want to search
r1 = ActiveSheet.UsedRange.Row
r2 = r1 + ActiveSheet.UsedRange.Rows.Count - 1
For r = r2 To r1 Step -1
If Cells(r, c) = "0" or Cells(r, c) = "1" or Cells(r, c) = "2" or Cells(r, c) = "3" Then Cells(r, 1).EntireRow.Delete
Next r
End Sub
Related
I have a sheet with some cells are merged in rows, and some are not. I want to wrap all the cells and if rows contains merged cells, set the rows height to max of all cells height
In the excel file, you can find the sheet I am working with, what I want to have, the excel macro I wrote, what I get with that macro. I also put them here.
This is what I have: (column D is a hidden column)
This is what I want to have: (for the rest of the sheet see attached excel file)
I wrote an excel VBA macro to do the job, but there is no luck.
Sub MergeCells2()
Application.DisplayAlerts = False
Dim allRange As Range
Dim xCell As Range
On Error Resume Next
Dim i_row As Integer
Dim nRowsToMerge As Integer
Dim rangeToMerge As Range
Worksheets("What I have").Activate
LastCol = ActiveSheet.Range("a1").End(xlToRight).Column
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, LastCol).End(xlUp).Row
Set allRange = Application.Range("a1", ActiveSheet.Cells(LastRow, LastCol))
allRange.WrapText = True
If allRange Is Nothing Then Exit Sub
nRowsToMerge = 1
Set heightToSet = Range("A2").RowHeight
For i_row = 2 To LastRow
Set i_rowRange = allRange.Rows(i_row - 1)
If (allRange.Cells(i_row, 1) = "") Then
nRowsToMerge = nRowsToMerge + 1
ElseIf nRowsToMerge = 1 Then
heightToSet = i_rowRange.RowHeight
Else
Set rangeToMerge = ActiveSheet.Range(ActiveSheet.Cells(i_row - nRowsToMerge, 1), ActiveSheet.Cells(i_row - 1, LastCol))
For Each xCell In rangeToMerge
cellrow = xCell.Row
If (rangeToMerge.Cells(cellrow, 1) = "") Then
If xCell.Value = "" Then
Range(xCell, xCell.Offset(-1, 0)).Merge
End If
End If
Next
rangeToMerge.RowHeight = heightToSet
heightToSet = i_rowRange.RowHeight
nRowsToMerge = 1
End If
Next i_row
End Sub
This is what I get:
I don't know what is wrong with it and I have to say that I don't know much about VBA programming.
I hope I was clear with my question.
Please help, I am working on this for days now :(
Cheers,
Eda
The idea:
Start by wrapping all cells, and using AutoFit for all rows. This way Excel will automatically set the row height properly.
Loop through the rows merging the cells and dividing the height of the row with the wrapped text over the rows to be merged.
This is how:
Sub NewMerger()
Dim r As Long, rMax As Long, re As Long, cMax As Long, c As Long, n As Long, h As Single, mr As Long
Application.DisplayAlerts = False
'Create a copy of the input
Sheets("What I have").Copy After:=Sheets(Sheets.Count)
On Error Resume Next
Sheets("New Result").Delete
ActiveSheet.Name = "New Result"
'merge and use autofit to get the ideal row height
Cells().WrapText = True
Rows.AutoFit
'get max row and column
cMax = Cells(1, 1).End(xlToRight).Column
rMax = Cells(Rows.Count, 1).End(xlUp).Row
'loop through rows, bottom to top
For r = rMax To 2 Step -1
If Cells(r, 1).Value = "" Then
If re = 0 Then re = r 'If we don't have an end row, we do now!
ElseIf re > 0 Then 'If re has an end row and the current row is not empty (AKA start row)
h = Rows(r).RowHeight 'Get the row height of the start row
n = re - r + 1 'calculate the number of rows
If n > 0 Then Rows(r & ":" & re).RowHeight = h / n 'devide the row hight over all rows
For c = 1 To cMax 'And merge
For mr = re To r Step -1 'Merge only empty cells
If Cells(mr, c).Value = "" Then
Range(Cells(mr, c), Cells(mr - 1, c)).MergeCells = True
End If
Next
Next
re = 0 'We don't have an end row now
End If
Next
Application.DisplayAlerts = True
End Sub
I am trying to compare two Range and copy data based on IF and AND condition, but AND condition is not working as a result data is being copied only based on IF condition. Please suggest what change should I make in code. Below is Code which I am currently using:
Sub Copy3()
Dim mCell As Range
Dim yRange As Range
Dim mRange As Range
Dim RRange As Range
Set mRange = Worksheets("Sheet2").Range("DB2:DB17")
Set yRange = Worksheets("Sheet2").Range("CZ2:CZ17")
Set RRange = Worksheets("Sheet2").Range("CY2:CY17")
Set target = mRange.Offset(columnoffset:=-3)
Dim P As Long, Q As Long, t As Long
For P = 1 To mRange.Cells.Count
For Q = 1 To RRange.Cells.Count
For t = 1 To yRange.Cells.Count
If mRange.Cells(P).Value <> "" And RRange.Cells(Q).Value <> yRange.Cells(t).Value Then
mRange.Cells(P).Copy target.Cells(P)
End If
Next
Next
Next
End Sub
you can try this (the sheet name and ranges must be changed to reflect the structure of your data). I made the assumption that target points to column A. The address of the cells is traced to make it easier to check if this is in deed what you expect the code to do.
Dim wholeRange As Range
Set wholeRange = Worksheets("Feuil1").Range("A2:D17")
If (Not wholeRange Is Nothing) Then
Dim row As Range, rP As Range, rQ As Range, rR As Range, rT As Range
For Each row In wholeRange.Rows
Set rP = row.Offset(0, 1).Resize(1, 1)
Set rR = row.Offset(0, 2).Resize(1, 1)
Set rQ = row.Offset(0, 3).Resize(1, 1)
Set rT = row.Offset(0, 0).Resize(1, 1)
Debug.Print "P:" + rP.Address + " R:" + rR.Address + " Q:" + rQ.Address + " T:" + rT.Address
If (rP.Cells(1, 1).Value <> "") And (rQ.Cells(1, 1).Value <> rT.Cells(1, 1).Value) Then
rP.Cells(1, 1).Value = rT.Cells(1, 1).Value
End If
Next row
Else
Debug.Print "wholeRange range is not defined"
End If
I am having trouble trying to include something into a macro I am building. I need it to search through column C
for cells that say "start trans" and in one column over (d)- the first value will be equal to zero, next instance should be 100, next instance 0 next instance 100 so on until the end of the data.
Instances are not always every 4th line and I have other zeros that I want it to overlook.
Thank you for any help!
How about this one:
Sub GoGoGo()
Dim l As Long: Dim i As Long
Dim b As Boolean
With ActiveSheet
l = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 5 To l
If .Cells(i, "C").Value2 = "start trans" Then .Cells(i, "D").Value2 = b * -100: b = Not b
Next i
End With
End Sub
Try this.
Sub test()
Dim rngDB As Range, rng As Range
Dim n As Long, Result As Integer
Set rngDB = Range("c5", Range("c" & Rows.Count).End(xlUp))
For Each rng In rngDB
If rng = "start trans" Then
n = n + 1
If n Mod 2 Then
Result = 0
Else
Result = 100
End If
rng.Offset(0, 1) = Result
End If
Next rng
End Sub
Hi all I am trying to make a vb macro that determins are there 4 empty cells in a row if so it should put 0 in a next row otherwais 1 Here is what I 've done so far
Sub QuickCull()
On Error Resume Next
Columns("a").SpecialCells(xlBlanks).EntireRow.Delete
Columns("b").SpecialCells(xlBlanks).EntireRow.Delete
Columns("d").SpecialCells(xlBlanks).EntireRow.Delete
Dim col As Range
Set col = Cells(Rows.Count, "E").End(xlUp)
Dim r As Range
Set r = Range("E2", col).Resize(, 4)
r.Select
Dim cell As Range
For Each cell In r
If cell.Value = "" Then
cell.Value = 0
Else
cell.Value = 1
End If
Next cell
End Sub
This way I put 0 instad of one blank row I thought about making another cell with a sum of those rows, but is where a way to do it more queckly and productivly?
I think you need something like the following, obviously replace "WORKSHEETNAME" with the name of the worksheet:
Dim r as Range, cell as Range, eRow as Long
eRow = Sheets("WORKSHEETNAME").Cells(Rows.Count, 5).End(xlUp).Row
Set r = Sheets("WORKSHEETNAME").Range("E2:E" & eRow)
For each cell in r.cells
If cell.Offset(0,-4).Value = "" _
And cell.Offset(0,-3).Value = "" _
And cell.Offset(0,-2).Value = "" _
And cell.Offset(0,-1).Value = "" Then
cell.Value = 0
Else
cell.Value = 1
End if
Next cell
I have two worksheets ( sheet 1 and sheet 2) . Sheet 1 has 500X500 table. I want to
- Loop through each row ( each cell )
- Identify the cells which have a value ' X' in it
- Pick the respective column header value and store it in a cell in worksheet 2
For example
AA BB CC DD EE FF GG HH
GHS X
FSJ X
FSA X
MSD
SKD
SFJ X X
SFJ
SFM X
MSF X
Is there a way of writing a macro which will pull values in the form of
GHS -> GG
FSJ->DD
.
.
SFJ->BB HH
I have tried looping algorithms but does not seem to work. Could anyone please help me as I am very new to macros.
Try this .. Assumed that GHS, FSJ ... in column A
Sub ColnItem()
Dim x, y, z As Integer
Dim sItem, sCol As String
Dim r As Range
z = 1
For y = 1 To 500
sItem = Cells(y, 1)
sCol = ""
For x = 2 To 500
If UCase(Cells(y, x)) = "X" Then
If Len(sCol) > 0 Then sCol = sCol & " "
sCol = sCol & ColumnName(x)
End If
Next
If Len(sCol) > 0 Then
Sheets("Sheet2").Cells(z, 1) = sItem & " -> " & sCol
z = z + 1
End If
Next
End Sub
Function ColumnName(ByVal nCol As Single) As String
Dim sC As String
Dim nC, nRest, nDivRes As Integer
sC = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
nC = Len(sC)
nRest = nCol Mod nC
nDivRes = (nCol - nRest) / nC
If nDivRes > 0 Then ColumnName = Mid(sC, nDivRes, 1)
ColumnName = ColumnName & Mid(sC, nRest, 1)
End Function
I have placed the values GG, etc., in separate columns of Sheet2, but the code could be modified to put all the information (for a row) in a single cell.
Sub GetColumnHeadings()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng1 As Range, rng2 As Range, rng As Range
Dim off As Integer
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng1 = ws1.Range("A1").CurrentRegion
'CurrentRegion is the Range highlighted when we press Ctrl-A from A1
Set rng2 = ws2.Range("A1")
Application.ScreenUpdating = False
For Each rng In rng1
If rng.Column = 1 Then off = 0
If rng.Value = "X" Then
rng2.Value = rng.EntireRow.Cells(1, 1).Value
off = off + 1
rng2.Offset(0, off).Value = rng.EntireColumn.Cells(1, 1).Value
End If
'if we are looking at the last column of the Sheet1 data, and
'we have put something into the current row of Sheet2, move to
'the next row down (in Sheet2)
If rng.Column = rng1.Column And rng2.Value <> "" Then
Set rng2 = rng2.Offset(1, 0)
End If
Next rng
Application.ScreenUpdating = True
Set rng = Nothing
Set rng2 = Nothing
Set rng1 = Nothing
Set ws2 = Nothing
Set ws1 = Nothing
End Sub
I've also based in on the spreadsheet sample from the original post, where AA appears to be in cell A1.