Sub Demo()
Application.ScreenUpdating = False
Dim r as Long
Dim C As Range
With ActiveDocument.Tables(1)
For r = 2 To .Rows.Count
With .Rows(r)
If .Cells.Count < 5 Then .Cells(2).Delete
If .Cells.Count > 4 Then .Cells(3).Delete
End WIth
Next
ActiveDocument.Tables(1).Cell(1,2).Delete
End With
Application.ScreenUpdating = True
End Sub
As I indicated in your other thread, the process has to be done at the cell level. Thus:
With .Rows(r)
If .Cells.Count < 3 Then
.Cells(2).Width = InchesToPoints(4)
.Cells(3).Width = InchesToPoints(2)
ElseIf .Cells.Count > 4 Then
.Cells(2).Width = InchesToPoints(4)
.Cells(3).Width = InchesToPoints(2)
.Cells(4).Width = InchesToPoints(3)
End If
End With
Related
I am looking to speed up an on-worksheet open macro I have in excel.
Every time the worksheet is opened, I would like it to autofit x rows and then hide any rows that have a 0 in it.
The macro works fine, but I think there must be a better/faster way to hide all relevant rows. Any help would be appreciated.
Private Sub Worksheet_Activate()
Rows("14:859").EntireRow.AutoFit
Application.ScreenUpdating = False
Dim c As Range
For Each c In Range("O1:O859").Cells
If c.Value = "0" Then
c.EntireRow.Hidden = True
End If
Next c
Application.ScreenUpdating = True
End Sub
Try this version:
Option Explicit
Private Sub Worksheet_Activate()
Const LAST_ROW = 859
Const CL = 15 'O column
Const RO = 14
Const HIDE_ROWS = True 'or False
Dim ur As Variant, hr As Range, R As Long
Application.ScreenUpdating = False
Rows(RO & ":" & LAST_ROW).EntireRow.AutoFit
ur = Range(Cells(1, CL), Cells(LAST_ROW, CL))
For R = 1 To LAST_ROW
If Len(ur(R, 1)) = 0 Then Exit For
If ur(R, 1) = 0 Then
If hr Is Nothing Then Set hr = Cells(R, 1) Else: Set hr = Union(hr, Cells(R, 1))
End If
Next
hr.EntireRow.Hidden = HIDE_ROWS
Application.ScreenUpdating = True
End Sub
I got this macro from this site but after running it the seems to behaving abnormally. Macro is running good and removing all blanks and empty rows and column but after running it I'm having problem to perform other formulas like plus minus in a range.
My code:
Sub RemoveBlankRowsColumns()
'PURPOSE: Remove blank rows or columns contained in the spreadsheets UsedRange
Dim rng As Range
Dim rngDelete As Range
Dim RowCount As Long, ColCount As Long
Dim EmptyTest As Boolean, StopAtData As Boolean
Dim RowDeleteCount As Long, ColDeleteCount As Long
Dim x As Long
Dim UserAnswer As Variant
'Analyze the UsedRange
Set rng = ActiveSheet.UsedRange
rng.Select
RowCount = rng.Rows.Count
ColCount = rng.Columns.Count
DeleteCount = 0
'Optimize Code
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'Loop Through Rows & Accumulate Rows to Delete
For x = RowCount To 1 Step -1
'Is Row Not Empty?
If Application.WorksheetFunction.CountA(rng.Rows(x)) <> 0 Then
If StopAtData = True Then Exit For
Else
If rngDelete Is Nothing Then Set rngDelete = rng.Rows(x)
Set rngDelete = Union(rngDelete, rng.Rows(x))
RowDeleteCount = RowDeleteCount + 1
End If
Next x
'Delete Rows (if necessary)
If Not rngDelete Is Nothing Then
rngDelete.EntireRow.Delete Shift:=xlUp
Set rngDelete = Nothing
End If
'Loop Through Columns & Accumulate Columns to Delete
For x = ColCount To 1 Step -1
'Is Column Not Empty?
If Application.WorksheetFunction.CountA(rng.Columns(x)) <> 0 Then
If StopAtData = True Then Exit For
Else
If rngDelete Is Nothing Then Set rngDelete = rng.Columns(x)
Set rngDelete = Union(rngDelete, rng.Columns(x))
ColDeleteCount = ColDeleteCount + 1
End If
Next x
'Delete Columns (if necessary)
If Not rngDelete Is Nothing Then
rngDelete.Select
rngDelete.EntireColumn.Delete
End If
'Refresh UsedRange (if necessary)
If RowDeleteCount + ColDeleteCount > 0 Then
ActiveSheet.UsedRange
End If
End Sub
Condensed code:
Sub RemoveBlankRowsColumns()
'PURPOSE: Remove blank rows or columns contained in the spreadsheets UsedRange
Dim RowCount As Long, ColCount As Long, x As Long
'Dim EmptyTest As Boolean, StopAtData As Boolean
Dim RowDeleteCount As Long: RowDeleteCount = 0
Dim ColDeleteCount As Long: ColDeleteCount = 0
Dim DeleteCount As Long: DeleteCount = 0
'Dim UserAnswer As Variant
On Error GoTo ExitSub
With ActiveSheet.UsedRange
RowCount = .Rows.Count
ColCount = .Columns.Count
'Optimize Code
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'Loop Through Rows & Delete
For x = RowCount To 1 Step -1
'Is Row Not Empty?
If Application.WorksheetFunction.CountA(.Rows(x)) <> 0 Then
If StopAtData = True Then Exit For
Else
.Rows(x).EntireRow.Delete Shift:=xlUp
RowDeleteCount = RowDeleteCount + 1
End If
Next x
'Loop Through Columns & Delete
For x = ColCount To 1 Step -1
'Is Column Not Empty?
If Application.WorksheetFunction.CountA(.Columns(x)) <> 0 Then
If StopAtData = True Then Exit For
Else
.Columns(x).EntireColumn.Delete Shift:=xlLeft
ColDeleteCount = ColDeleteCount + 1
End If
Next x
DeleteCount = RowDeleteCount + ColDeleteCount
End With
ExitSub:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Is there a faster, or more practical way of hiding rows in all sheets that have a zero value in column A? I have set up multiple macros to hide the rows, but this takes about 50-70 secs to complete any faster way?
Sub Macro14()
Dim c As Range
For Each c In Sheets("Main").Range("A200:A500")
If c.value = 0 Then
Sheets("Main").Rows(c.Row).Hidden = True
Else
Sheets("Main").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro15()
Dim c As Range
For Each c In Sheets("Elkhart East").Range("A50:A300")
If c.value = 0 Then
Sheets("Elkhart East").Rows(c.Row).Hidden = True
Else
Sheets("Elkhart East").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro16()
Dim c As Range
For Each c In Sheets("Tennessee").Range("A50:A300")
If c.value = 0 Then
Sheets("Tennessee").Rows(c.Row).Hidden = True
Else
Sheets("Tennessee").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro17()
Dim c As Range
For Each c In Sheets("Alabama").Range("A50:A300")
If c.value = 0 Then
Sheets("Alabama").Rows(c.Row).Hidden = True
Else
Sheets("Alabama").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro18()
Dim c As Range
For Each c In Sheets("North Carolina").Range("A50:A300")
If c.value = 0 Then
Sheets("North Carolina").Rows(c.Row).Hidden = True
Else
Sheets("North Carolina").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro19()
Dim c As Range
For Each c In Sheets("Pennsylvania").Range("A50:A300")
If c.value = 0 Then
Sheets("Pennsylvania").Rows(c.Row).Hidden = True
Else
Sheets("Pennsylvania").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro20()
Dim c As Range
For Each c In Sheets("Texas").Range("A50:A300")
If c.value = 0 Then
Sheets("Texas").Rows(c.Row).Hidden = True
Else
Sheets("Texas").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro21()
Dim c As Range
For Each c In Sheets("West Coast").Range("A50:A300")
If c.value = 0 Then
Sheets("West Coast").Rows(c.Row).Hidden = True
Else
Sheets("West Coast").Rows(c.Row).Hidden = False
End If
Next
End Sub
This should do it in a pretty fast way:
Sub test()
Dim x As Variant, i As Long, j(1) As Long, rngVal As Variant, rnghide As Range, rngshow As Range, sht As Object
For Each sht In ActiveWorkbook.Sheets(Array("Main", "Elkhart East", "Tennessee", "Alabama", "North Carolina", "Pennsylvania", "Texas", "West Coast"))
Set rnghide = Nothing
Set rngshow = Nothing
If sht.Name = "Main" Then
j(0) = 200
j(1) = 500
Else
j(0) = 50
j(1) = 300
End If
x = sht.Range("A1:A" & j(1)).Value
For i = j(0) To j(1)
If x(i, 1) = 0 Then
If rnghide Is Nothing Then Set rnghide = sht.Rows(i) Else Set rnghide = Union(rnghide, sht.Rows(i))
Else
If rngshow Is Nothing Then Set rngshow = sht.Rows(i) Else Set rngshow = Union(rngshow, sht.Rows(i))
End If
Next
rnghide.EntireRow.Hidden = True
rngshow.EntireRow.Hidden = False
Next
End Sub
It simply runs each sheet for the whole range and stores the rows to show/hide in seperate ranges and then change there status in one step (1 for show and 1 for hide for each sheet)
If you have any questions or get any errors just tell me (can't test it right now)
Use an array:
Sub t()
Dim sheetArray() As Variant
Dim ws&, finalRow&, startRow&
Dim c As Range
sheetArray = Array("Alabama", "North Carolina", "West Coast")
For ws = LBound(sheetArray) To UBound(sheetArray)
If sheetArray(ws) = "Main" Then
startRow = 200
finalRow = 500
Else
startRow = 50
finalRow = 300
End If
For Each c In Sheets(sheetArray(ws)).Range("A" & startRow & ":A" & finalRow)
If c.Value = 0 And Not IsEmpty(c) Then
Sheets(sheetArray(ws)).Rows(c.Row).Hidden = True
Else
Sheets(sheetArray(ws)).Rows(c.Row).Hidden = False
End If
Next c
Next ws
End Sub
Just add to that array and it should work a little faster for you. If you have a ton of sheets, and don't want to manually type them into the VBA code, you can always set the array to the range of sheet names, then just go from there. Let me know if you need help doing so.
This also assumes you don't want to just loop through the workbook. If so, you can just do For each ws in ActiveWorkbook instead of lBound()...
Edit: I added some code to check the sheet, so it'll correctly adjust your ranges.
use this :
For Each ws In ActiveWorkbook.Worksheets
For Each c In ws.Range(IIf(ws.Name = "Main", "A200:A500", "A50:A300"))
ws.Rows(c.Row).Hidden = c.Value = 0
Next
Next
if you want exclude sheet Raw,Main and Calendar :
Dim untreatedSheet As Variant
untreatedSheet = Array("Raw", "Main", "Calendar")
For Each ws In ActiveWorkbook.Worksheets
If Not (UBound(Filter(untreatedSheet, ws.Name)) > -1) Then
For Each c In ws.Range("A50:A300")
ws.Rows(c.Row).Hidden = c.Value = 0
Next
End If
Next
This will work if you select all the sheets you want filtered FIRST:
Sub HideRows()
Dim ws As Worksheet
sAddress = "A:A"
For Each ws In ActiveWindow.SelectedSheets
ws.Range(sAddress).AutoFilter Field:=1, Criteria1:="<>0"
Next ws
End Sub
I have the following basic script that merges cells with the same value in Column R
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("R1:R1000")
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
What I would like to do is repeat this in columns A:Q and S:T but, I would like these columns to be merged in the same merged cell ranges as column R, i.e. if R2:R23 is merged then A2:A23, B2:B23, C2:C23 etc. will also be merge.
Columns A:Q do not contain values, column S:T have values but, these will be the same values throughout the range.
Any ideas
Apols for the earlier edit - this now deals with more than one duplicate in col R.
Note that this approach will work on the current (active) sheet.
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim cval As Variant
Dim currcell As Range
Dim mergeRowStart As Long, mergeRowEnd As Long, mergeCol As Long
mergeRowStart = 1
mergeRowEnd = 1000
mergeCol = 18 'Col R
For c = mergeRowStart To mergeRowEnd
Set currcell = Cells(c, mergeCol)
If currcell.Value = currcell.Offset(1, 0).Value And IsEmpty(currcell) = False Then
cval = currcell.Value
strow = currcell.Row
endrow = strow + 1
Do While cval = currcell.Offset(endrow - strow, 0).Value And Not IsEmpty(currcell)
endrow = endrow + 1
c = c + 1
Loop
If endrow > strow+1 Then
Call mergeOtherCells(strow, endrow)
End If
End If
Next c
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub mergeOtherCells(strw, enrw)
'Cols A to T
For col = 1 To 20
Range(Cells(strw, col), Cells(enrw, col)).Merge
Next col
End Sub
You can try the below code as well. It would require you to put a 'No' after the last line in column R (R1001) so as to end the while loop.
Sub Macro1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
flag = False
k = 1
While ActiveSheet.Cells(k, 18).Value <> "No"
i = 1
j = 0
While i < 1000
rowid = k
If Cells(rowid, 18).Value = Cells(rowid + i, 18).Value Then
j = j + 1
flag = True
Else
i = 1000
End If
i = i + 1
Wend
If flag = True Then
x = 1
While x < 21
Range(Cells(rowid, x), Cells(rowid + j, x)).Merge
x = x + 1
Wend
flag = False
k = k + j
End If
k = k + 1
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have a big Excel sheet containing +100k rows and have an autofilter on one column of text values with category numbers and descriptions. There are thousands of different values in column F, so updating the autofilter is very impractical via using the standard UI.
How can I create a macro that removes the currently active cell's value from the autofilter that is active on the same column?
With the help of an expert, we came to a working solution for my case.
Just posting this as solution for others:
Sub Clear_Filter_and_Value()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim w As Worksheet
Dim filterArray()
Dim currentFiltRange As String
Dim col As Integer
Dim flag As Boolean
Set w = ActiveSheet
If w.AutoFilterMode = False Then Selection.AutoFilter
flag = False
On Error GoTo exit1
With w.AutoFilter
currentFiltRange = .Range.Address
With .Filters
For f = 1 To .Count
With .Item(f)
If .On Then
If ActiveCell.Column = f Then
ReDim filterArray(1 To .Count)
If .Count = 2 Then
filterArray(1) = .Criteria1
filterArray(2) = .Criteria2
Else
filterArray(1) = .Criteria1
End If
End If
ElseIf ActiveCell.Column = f Then
tR = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
ReDim filterArray(1 To tR - 1)
For i = 2 To tR
filterArray(i - 1) = Cells(i, ActiveCell.Column).Value
flag = True
Next i
End If
End With
Next f
End With
End With
w.AutoFilterMode = False
j = 1
ReDim newArray(1 To UBound(filterArray))
If flag = False Then
On Error GoTo 1
For i = 1 To UBound(filterArray(1))
On Error GoTo 1
If InStr(1, filterArray(1)(i), ActiveCell.Value) = 0 Then
newArray(j) = filterArray(1)(i)
j = j + 1
End If
Next i
Else
1:
Err.Clear
For i = 1 To UBound(filterArray)
If InStr(1, filterArray(i), ActiveCell.Value) = 0 Then
newArray(j) = filterArray(i)
j = j + 1
End If
Next i
End If
For col = 1 To 1
If Not IsEmpty(filterArray(1)) Then
w.Range(currentFiltRange).AutoFilter Field:=ActiveCell.Column, Criteria1:=newArray, Operator:=xlFilterValues
End If
Next col
exit1:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub