In column A, we have numbers of 1 to 10 respectively
And in column B we hold letters a to j which do not have order
We removed 4 letters
I do not want to change column A but column B removes her empty cells and letters writing following
The following code removes rows with empty cells:
Sub DeleteEmptyRows()
' Deletes the entire row within the selection if the ENTIRE row contains no data.
Dim i As Long
ActiveSheet.UsedRange.Select
With Application
' Turn off calculation and screenupdating to speed up the macro.
.Calculation = xlCalculationManual
.ScreenUpdating = False
For i = Selection.Rows.Count To 2 Step -1
If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then Selection.Rows(i).EntireRow.Delete
Next i
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
This solution will loop through the rangeAreas, copy the contents in Column B of that area, remove the blanks, and but the results back in column b, I requires column Z as a helper column
Sub Button1_Click()
Dim RangeArea As Range, x
For Each RangeArea In Columns("A").SpecialCells(xlCellTypeConstants, 1).Areas
x = RangeArea.Rows.Count
RangeArea.Offset(, 1).Copy [z1]
Columns("Z:Z").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
RangeArea.Offset(, 1).Value = Range("Z1:Z" & x).Value
Range("Z:Z").Delete
Next RangeArea
End Sub
I don't understand how you get from your first picture to the second, but if you start from the second, this will get you to the third.
Sub x()
On Error Resume Next 'avoid error if no blank cells
Columns("B").SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
On Error GoTo 0
End Sub
Related
I am working on a macro in Excel that will hide any columns that are empty. However, they aren't TOTALLY empty, because I want the headers to still be there. For example, the headers are on Row 3. So, for column A, I want column A to be hidden if there is not data in the range("A4:A" & rng), rng being the last row. I was able to successfully write code for just column A and technically I could write this code for each row in the spreadsheet, but it goes from column A to AU. That would be a lot of code.
There has to be a way to loop through each column and hide the column based on their range of row 4 through the last row. Please let me know!
Here is my code for just column A that works correctly. It loops through each cell in column A and if they are all empty, cellsEmpty is True and the column is hidden. If any of the cells have data in them, cellsEmpty is False and we exit the For. How do I loop through each column and apply this code to each column?
Sub hideEmptyColumns()
rng = WorksheetFunction.CountA(Worksheets("Sheet1").Range("A1:A1000")) + 2
'+2 because of the top 2 blank rows
Dim i As Range
Dim cellsEmpty As Boolean
cellsEmpty = True
Application.ScreenUpdating = False
For Each i In Range("A4:A" & rng)
If i.Value <> "" Then
cellsEmpty = False
Exit For
End If
Next
If cellsEmpty = True Then
Columns("A").Hidden = True
End If
Application.ScreenUpdating = True
End Sub
Loop through each column and get the last row, if less than or equal to 3 then hide.
Dim lc As Long
Dim lr As Long
Dim i As Long
With Sheets("Sheet1")
lc = .Cells(3, .Columns.Count).End(xlToLeft).Column
For i = 1 To lc
lr = .Cells(.Rows.Count, i).End(xlUp).Row
If lr <= 3 Then
Columns(i).Hidden = True
End If
Next i
End With
I´m trying to create an Excelsheet that runs multiple VBA scripts after writing anything in A Column.
One part I would like some help with is that the character 2,3 and 4 written in A column (any row) should be written i D column same row.
I also would like to remove any information i D Column if I remove the text from A Column.
I have manage to create a script that calls modules after writing information i a cell in A Column
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Me.Range("A:A")) Is Nothing Then Exit Sub
Application.EnableEvents = False 'to prevent endless loop
On Error GoTo Finalize 'to re-enable the events
Call Modul1.Module
Finalize:
Application.EnableEvents = True
End Sub
Any help would be much appriciated.
This is what I have for now.
It doesn´t work to clear value on all rows only some of them?!
Sub Lokation()
Dim n As Long, i As Long, j As Long
n = Cells(Rows.Count, "A").End(xlUp).Row
j = 2
For i = 2 To n
If Cells(i, "A").Value = vbNullString Then
Cells(j, "D").Value = ("")
Else
Cells(j, "D").Value = Mid(Cells(j, "A").Value, 2, 3)
End If
j = j + 1
Next i
End Sub
You can wrap this whole piece up in just the Worksheet_Change event if you use the following:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim columnAcell As Range
If Intersect(Target, Me.Range("A:A")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each columnAcell In Target.Cells
columnAcell.Offset(0, 3) = Mid(columnAcell, 2, 3)
Next
Application.EnableEvents = True
End Sub
Instead of specifically writing to column D, I've used a cell offset of 3 columns from Target. As this code only looks at column A currently, it will always offset to column D.
Things to watch out for though -
Altering cell(A1) which contains the header would result in cell(D1) being altered. You can prevent this by changing the Intersect range from A:A to something like A2:Axxxx
Deleting the entirety of column A would result in the loop running for a very long time, not to mention causing column D to move to column C. You may want to prevent users from being able to do this.
I'm trying to check the contents of the cells in column Q and delete the rows that have a 0 in that column.
The macro should start checking in column Q at cell Q11 and stop when it encounters the cell containing the text "END". When finished it should select the cell at the upper left corner of the spreadsheet, which would normally be A1, but I have a merged cell there, so it's A1:K2.
Here are my two most recent versions of the macro:
'My second to last attempt
Sub DeleteRowMacro1()
Dim i As Integer
i = 11
Do
Cells(i, 17).Activate
If ActiveCell.Value = 0 Then
ActiveCell.EntireRow.Delete
End If
i = i + 1
Loop Until ActiveCell.Value = "END"
Range("A1:K2").Select
End Sub
'My last attempt
Sub DeleteRowMacro2()
Dim i As Integer
i = 11
GoTo Filter
Filter:
Cells(i, 17).Activate
If ActiveCell.Value = "END" Then GoTo EndingCondition
If ActiveCell.Value = "" Then GoTo KeepCondition
If ActiveCell.Value = 0 Then GoTo DeleteCondition
If ActiveCell.Value > 0 Then GoTo KeepCondition
EndingCondition:
Range("A1:K2").Select
KeepCondition:
i = i + 1
GoTo Filter
DeleteCondition:
ActiveCell.EntireRow.Delete
i = i + 1
GoTo Filter
End Sub
What DeleteRowMacro1() Does:
It leaves the row if there is text or a number greater than 0 in column Q, but it deletes the rows with cells with a 0 AND blank cells. I want to keep the rows with the blank cells.
This macro seems to be incapable of checking the 450 or so cells between the Q11 and the cell with "END" in one run. It only deletes about half of the rows it should each time. The first 10 or so rows are always done correctly, but then it appears to randomly choose rows with a zero or a blank in column Q to delete.
If I run the macro 7 or 8 times, it will eventually delete all of the rows with a 0 and the ones that are blank too. I would like it to completely do it's job in one run and not delete the rows with blank cells.
What DeleteRowMacro2() Does:
It never stops at "END".
I have to run it 7 or 8 times to completely get rid of all of the rows with a 0 in column Q. It also appears to randomly check cells for deletion (and once again besides the first 10 or so).
Because it never ends when I run it, the area of my screen where the spreadsheet is turns black and all I can see there is the green selected cell box flickering up and down at random locations in the Q column until it gets to a row number in the 32,000s. After that my screen returns to show the normal white spreadsheet and a box appears that says Run-time error '6': Overflow.
Please note: After I click "End" on the error box I can see that the macro worked as described above.
Try it as,
Option Explicit
Sub DeleteRowMacro3()
Dim rwend As Variant
With Worksheets("Sheet5")
If .AutoFilterMode Then .AutoFilterMode = False
rwend = Application.Match("end", .Range(.Cells(11, "Q"), .Cells(.Rows.Count, "Q")), 0)
If Not IsError(rwend) Then
With .Range(.Cells(10, "Q"), .Cells(rwend + 10, "Q"))
.AutoFilter Field:=1, Criteria1:=0, Operator:=xlOr, Criteria2:=vbNullString
With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
End With
End With
End If
.Activate
.Range("A1:K2").Select
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
I wasn't sure if you were looking specifically for zeroes or zero value so I included blank cells as well as numerical zeroes.
First, it's best practice to avoid using .Select/.Activate. That can cause some confusion and tricky writing when doing loops/macros in general.
Second, it's also best to avoid GoTo.
This macro will start at the last row in column Q, and make its way toward row 11. If the value of a cell is 0, it'll delete the row. If the value is END, it selects your range and exits the For loop, and then exits the sub.
Sub delRows()
Dim lastRow As Long, i As Long
Dim ws as Worksheet
Set ws = Worksheets("Sheet1") ' CHANGE THIS AS NECESSARY
lastRow = ws.Cells(ws.Rows.Count, 17).End(xlUp).Row
For i = lastRow To 11 Step -1
If ws.Cells(i, 17).Value = "END" Then
ws.Range("A1:K2").Select
Exit For
End If
If ws.Cells(i, 17).Value = 0 or ws.Cells(i, 17).Value = "0" Then
ws.Cells(i, 17).EntireRow.Delete
End If
Next i
End Sub
Try this variation of your first code:
Sub DeleteRowMacro1()
Dim i As Integer
i = 11
Do
Cells(i, 17).Activate
If IsEmpty(ActiveCell.Value) Then
ActiveCell.EntireRow.Delete
End If
If ActiveCell.Value = "END" Then
Exit Do
End If
i = i + 1
Loop
Range("A1:K2").Select
End Sub
Try this simpler, and faster version. It will locate all of the cells you want to delete, store them in a range object, and then delete them all at once at the end.
Public Sub DeleteRowsWithRange()
Dim rngLoop As Range
Dim rngMyRange As Range
For Each rngLoop In Columns("Q").Cells
If rngLoop.Value = "END" Then
Exit For
ElseIf rngLoop.Value = 0 Then
If rngMyRange Is Nothing Then
Set rngMyRange = rngLoop.EntireRow
Else
Set rngMyRange = Union(rngMyRange, rngLoop.EntireRow)
End If
End If
Next rngLoop
If Not rngMyRange Is Nothing Then rngMyRange.Delete xlShiftUp
Range("A1").Activate
Set rngLoop = Nothing
Set rngMyRange = Nothing
End Sub
I have over 100 vendor lists I need to sort and align for a software system migration. If anyone knows this answer I will be grateful for any advice. I tried =VLOOKUP, =MATCH. I cannot figure out how to organize the data with the matching SKU's first.
This is an example of what the list looks like.
#105:CR1910-RT10G0 #105:GR1019-SL54FT
#105:CR1910-RT10M0 #105:GR1035-SL54F0
#105:GL1405-M078F0 #105:GR1035-SL54H0
#105:GL1407-0306C0 #105:GR1035-SL54P0
#105:GL1409-0306C0 #105:GR1019-SL54FT
#105:GL1409-0312C0 #105:GR1730-SL54P0
#105:GL1409-BR16C0 #105:GR1838-SL54H0
#105:GL1409-CL12C0 #105:GR1471-SL54P0
#105:GL1409-STGRCF #105:MB2172-SL54H0
#105:GL1412-0306C0 #105:MB2172-SL34H0
#105:GL1413-0306C0 #105:MB2172-SL54P0
#105:GL1428-0306C0 #105:MB2172-SL34P0
#105:GL1428-0306F0 #105:MB1810-SL34P0
#105:GL1428-0312C0 #105:MB1779-SL54P0
#105:GL1428-M078F1 #105:GR1768-SL54H0
#105:GL1428-ML12C0 #105:MB1809-SL54H0
#105:GL1428-STGRCF #105:MB1809-SL34H0
#105:GL1430-BRICF0 #105:MB1809-SL54P0
#105:GL1512-0208C0 #105:MB1809-SL34P0
#105:GL1512-0306C0 #105:GR1234-SL54P0
#105:GL1512-0306F0 #105:GR1879-SL54P0
#105:GL1512-0312C0 #105:GR1879-SL54V0
#105:GL1512-0312F0 #105:MB2053-SL54P0
#105:GL1512-BR16C0 #105:MB1806-SL54H0
Move your second column to another column, I used column C.
Then in new second column use this formula:
=IFERROR(VLOOKUP(C1,A:A,1,FALSE),"")
Then sort the new second column and the old second column on the new second column.
At this point you can either hide column A or Copy and paste the values in Column B and delete Column A.
To do this in VBA:
Sub MySort()
Dim ws As Worksheet
Dim rng As Range
Dim t As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set ws = ThisWorkbook.Worksheets("Sheet17") 'Change to your sheet
With ws
.[B:B].Insert
For Each rng In .Range(.Cells(1, 3), .Cells(.Rows.Count, 3).End(xlUp))
t = 0
On Error Resume Next
t = Application.WorksheetFunction.Match(rng, .Range("A:A"), 0)
On Error GoTo 0
If t > 0 Then rng.Offset(, -1).Value = rng.Value
Next rng
.Range("A:A").Delete
.Range("A:B").Sort Key1:=.Range("A1")
End With
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True
End Sub
I have the following macro that adds 0s to ID numbers until they are 7 numbers long. I have used it countless times before and it has always worked without fail until today it started not working and the portion of the code For i = 1 To endrow - 1 is highlighted every time and I cannot debug the issue. The whole code is.
Sub AddZeroes()
'Declarations
Dim i As Integer, j As Integer, endrow As Long
'Converts the A column format to Text format
Application.ScreenUpdating = False
Columns("A:A").Select
Selection.NumberFormat = "#"
'finds the bottom most row
endrow = ActiveSheet.Range("A1").End(xlDown).Row
'selects the top cell in column A
ActiveSheet.Range("A1").Select
'loop to move from cell to cell
For i = 1 To endrow - 1
'Moves the cell down 1. Assumes there's a header row so really starts at row 2
ActiveCell.Offset(1, 0).Select
'The Do-While loop keeps adding zeroes to the front of the cell value until it hits a length of 7
Do While Len(ActiveCell.Value) < 7
ActiveCell.Value = "0" & ActiveCell.Value
Loop
Next i
Application.ScreenUpdating = True
End Sub
Not sure what is causing the error - but would suggest another approach:
sub addZeros()
Application.ScreenUpdating = False
' start at row 2 since OP said there's a header row
Dim c as Range
for each c in Range("A2", [A2].End(xlDown))
c.Value = "'" & Format(c.Value, "00000000")
next c
Application.ScreenUpdating = True
end sub
A bit more compact...
Note that I'm adding the "'" apostrophe to make Excel treat the cell value as string. This is a safe way to make sure the zeros stay...
EDIT: Got rid of the last .Select to show it can be done, and is generally good practice as pointed out in comments.