I would like to delete all empty columns between 2 used ranges, based on the screenshot:
However, these two used ranges may have varying column length, thus the empty columns are not always Columns D to K.
Here is my code:
Sub MyColumns()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.Open ("BOOK2.xlsx")
Workbooks("BOOK2.xlsx").Activate
Workbooks("BOOK2.xlsx").Sheets(1).Activate
Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, 4).Value = "NON-EMPTY"
Dim finalfilledcolumn As Long
finalfilledcolumn = Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
Dim iCol As Long
Dim i As Long
iCol = firstfilledcolumn + 1
'Loop to delete empty columns
For i = 1 To firstfilledcolumn + 1
Columns(iCol).EntireColumn.Delete
Next i
Workbooks("BOOK2.xlsx").Close SaveChanges:=True
MsgBox "DONE!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
However, the empty columns still remain.
Do note that the last filled column for the first used range, Place = "USA", Price = "110" and Category = "Mechanical" may not be fixed at Column C, but could go to Column D, E, etc.
Many thanks!
Please, try the next way:
Sub deleteEmptyColumn()
Dim sh As Worksheet, lastCol As Long, rngColDel As Range, i As Long
Set sh = ActiveSheet 'use here your necessary sheet, having the workbook open
'if not open, you can handle this part...
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column
For i = 1 To lastCol
If WorksheetFunction.CountA(sh.Columns(i)) = 0 Then
If rngColDel Is Nothing Then
Set rngColDel = sh.cells(1, i)
Else
Set rngColDel = Union(rngColDel, sh.cells(1, i))
End If
End If
Next i
If Not rngColDel Is Nothing Then rngColDel.EntireColumn.Delete
End Sub
Try this ..
Dim rng As Range, i As Long
Set rng = Workbooks("BOOK2.xlsx").Sheets(1).UsedRange
For i = rng.Columns.Count To 1 Step -1
If WorksheetFunction.CountA(rng.Columns(i)) = 0 Then
rng.Columns(i).EntireColumn.Delete
End If
Next i
Related
I have a question about how to use a double loop to compare two Cells which are located in different sheets("Sheet1" and "Sheet2").
The condition I want to apply to the Loop is that in case if the two cells are different, the row must be hidden (Applied to the table located in Sheet1). In the contrary case, if the two cells are the same, the row stays as it is by default.
But with the Macro I wrote, it hides all rows that form the Sheet1 table. What could be the reason?
Sub HideRows()
Sheets("Sheet2").Select
Dim NR As Integer
NR = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
Sheets("Sheet1").Select
Dim i As Integer, j As Integer
For i = 2 To 10
For j = 1 To NR
If Cells(i, 1) <> Sheets("Sheet2").Cells(j, 1) Then
Rows(i & ":" & i).Select
Selection.EntireRow.Hidden = True
End If
Next j
Next I
End Sub
Sheet1:
Sheet2:
Desired result:
Your task is better described as
Hide all rows on Sheet1 whose column A value does not apear on Sheet2 column A
Using the looping the ranges technique you tried, this could be written as
Sub HideRows()
Dim rng1 As Range, cl1 As Range
Dim rng2 As Range, cl2 As Range
Dim HideRow As Boolean
With ThisWorkbook.Worksheets("Sheet1")
Set rng1 = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With ThisWorkbook.Worksheets("Sheet2")
Set rng2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
rng1.EntireRow.Hidden = False
For Each cl1 In rng1.Cells
HideRow = True
For Each cl2 In rng2.Cells
If cl1.Value2 = cl2.Value2 Then
HideRow = False
Exit For
End If
Next
If HideRow Then
cl1.EntireRow.Hidden = True
End If
Next
End Sub
That said, while this approach is ok for small data sets, it will be slow for larger data sets.
A better approach is to loop Variant Arrays of the data, and build a range reference to allow hiding all required rows in one go
Sub HideRows2()
Dim rng1 As Range, cl1 As Range, dat1 As Variant
Dim rng2 As Range, cl2 As Range, dat2 As Variant
Dim HideRow As Boolean
Dim r1 As Long, r2 As Long
Dim HideRange As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
dat1 = rng1.Value2
End With
With ThisWorkbook.Worksheets("Sheet2")
Set rng2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
dat2 = rng2.Value2
End With
rng1.EntireRow.Hidden = False
For r1 = 2 To UBound(dat1, 1)
HideRow = True
For r2 = 1 To UBound(dat2, 1)
If dat1(r1, 1) = dat2(r2, 1) Then
HideRow = False
Exit For
End If
Next
If HideRow Then
If HideRange Is Nothing Then
Set HideRange = rng1.Cells(r1, 1)
Else
Set HideRange = Application.Union(HideRange, rng1.Cells(r1, 1))
End If
End If
Next
If Not HideRange Is Nothing Then
HideRange.EntireRow.Hidden = True
End If
End Sub
#Chjris Neilsen has beaten me to most of what I wanted to mention. Please refer to his comment above. However, there are two things I want to add.
Please don't Select anything. VBA knows where everything is in your workbook. You don't need to touch. Just point.
i and j aren't really meaningful variable identifiers for Rows and Columns. They just make your task that much more difficult - as if you weren't struggling with the matter without the such extra hurdles.
With that out of the way, your code would look as shown below. The only real difference is the Exit For which ends the loop when the decision is made to hide a row. No guarantee that the procedure will now do what you want but the logic is laid are and shouldn't be hard to adjust. I point to .Rows(C).Hidden = True in this regard. C is not a row. It's a column.
Sub HideRows()
' always prefer Long datatype for rows and columns
Dim Rl As Long ' last row: Sheet2
Dim C As Long ' loop counter: columns
Dim R As Long ' loop counter: rows
Rl = WorksheetFunction.CountA(Sheet2.Columns(1))
With Sheet1
For C = 2 To 10
For R = 1 To Rl
' always list the variable item first
If Sheets("Sheet2").Cells(R, 1).Value <> .Cells(C, 1).Value Then
.Rows(C).Hidden = True
Exit For
End If
Next R
Next C
End With
End Sub
I have a two different worksheets with the same number of rows each one. In column R I have "New" or "Old" depending on the row (this is a dynamic value). What I want to do is, if a row in Worksheet1 contains "Old" in column R, then delete that row in both Worksheet1 and Worksheet2.
Now, I have tried two codes for this:
Dim w1 As Worksheet
Dim w2 As Worksheet
Set w1= Worksheets("Sheet1")
Set w2= Worksheets("Sheet2")
'-----------------------------------------------------
'Code 1
'-----------------------------------------------------
Application.ScreenUpdating = False
For r = w1.UsedRange.Rows.Count To 1 Step -1
If Cells(r, "R") = "Old" Then
w1.Rows(r).EntireRow.Delete
w2.Rows(r).EntireRow.Delete
End If
Next r
Application.ScreenUpdating = True
'-----------------------------------------------------
'Code 2
'-----------------------------------------------------
Dim i As Long
i = 1
Application.ScreenUpdating = False
Do While i <= w1.Range("R1").CurrentRegion.Rows.Count
If InStr(1, w1.Cells(i, 18).Text, "Old", vbTextCompare) > 0 Then
w1.Cells(i, 1).EntireRow.Delete
w2.Cells(i, 1).EntireRow.Delete
Else
i = i + 1
End If
Loop
Application.ScreenUpdating = True
Usually I have +800 rows, so Code 1 works as desired but it sometimes takes too long, like 3 minutes. Code 2 gets stuck so far.
What is an efficient way of doing this?
Delete Rows In Sheets
Implementing Union should considerably speed up the process.
The Code
Sub DeleteRowsInSheets()
Const cSheet1 As Variant = "Sheet1" ' First Worksheet Name/Index
Const cSheet2 As Variant = "Sheet2" ' First Worksheet Name/Index
Const cVntCol As Variant = "R" ' Search Column Letter/Number
Const cStrCriteria As String = "Old" ' Search Criteria String
Dim rngU1 As Range ' Union Range 1
Dim rngU2 As Range ' Union Range 2
Dim LastUR As Long ' Last Used Row
Dim i As Long ' Row Counter
With Worksheets(cSheet1)
' Calculate Last Used Row.
If .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
Is Nothing Then Exit Sub
LastUR = .Cells.Find("*", , , , , 2).Row
' Add found cells to Union Ranges.
For i = 1 To LastUR
If StrComp(.Cells(i, cVntCol), cStrCriteria, vbTextCompare) = 0 Then
If Not rngU1 Is Nothing Then
Set rngU1 = Union(rngU1, .Cells(i, 1))
Set rngU2 = Union(rngU2, Worksheets(cSheet2).Cells(i, 1))
Else
Set rngU1 = .Cells(i, 1)
Set rngU2 = Worksheets(cSheet2).Cells(i, 1)
End If
End If
Next
End With
' Delete rows.
If Not rngU1 Is Nothing Then
rngU1.EntireRow.Delete ' Hidden = True
rngU2.EntireRow.Delete ' Hidden = True
Set rngU2 = Nothing
Set rngU1 = Nothing
End If
End Sub
I think that there could be lots of formulas. So Application.Calculation = xlManual at the begining and Application.Calculation = xlCalculationAutomatic at the end should be good idea too.
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For r = w1.UsedRange.Rows.Count To 1 Step -1
If Cells(r, "R") = "Old" Then
w1.Rows(r).EntireRow.Delete
w2.Rows(r).EntireRow.Delete
End If
Next r
Application.ScreenUpdating = true
Application.Calculation = xlCalculationAutomatic
I am trying to copy all rows from an excel sheet (Sheet1) that have a specific value that is referenced from a different cell. and then paste them into a new sheet(Sheet2).
My specific example is I have figured out that I want to copy the rows that have a '0' and/or '35' in column A. these values can change however due to what ever is in "B6" and "B7".
The problem that I am having is it only copys rows that contain the value from "B6" which is 0 and ignoring my command that wants the "B7" value which is 35 in my instance. My code is below for reference
Sub Temp_copy()
set i = Sheets("Sheet1")
set e = Sheets("Sheet2")
Dim d
Dim j
d = 1
j = 2
Do Until IsEmpty(i.Range("A" & j))
If i.Range("A"&j) = Range("B6"&j) Then
d=d+1
e.Rows(d).Value=i.Rows(j).Value
End If
j = j+1
Loop
Do Until IsEmpty(i.Range("A" & j))
If i.Range("A"&j) = Range("B7"&j) Then
d=d+1
e.Rows(d).Value=i.Rows(j).Value
End If
j = j+1
Loop
End Sub
I am new to VBA so any help or guidance to achieve what I need would be muchly appreciated.
Instead of looping through cells, you may use Autofilter to copy the desired data like below...
Sub CopyRows()
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long
Application.ScreenUpdating = False
Set sws = Sheets("Sheet1")
Set dws = Sheets("Sheet2")
lr = sws.Cells(Rows.Count, 1).End(xlUp).Row
dws.Cells.Clear
sws.AutoFilterMode = False
'Assuming Row1 is the Header Row on Sheet1
With sws.Range("A1:A" & lr)
.AutoFilter field:=1, Criteria1:=sws.Range("B6").Value, Operator:=xlOr, Criteria2:=sws.Range("B7").Value
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
dws.Range("A1").PasteSpecial xlPasteValues
End With
sws.AutoFilterMode = False
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
The simple or operator will help you get this done!
Sub Temp_copy()
Set i = Sheets("Sheet1")
Set e = Sheets("Sheet2")
Dim d
Dim j
d = 1
j = 2
Do Until IsEmpty(i.Range("A" & j))
If i.Range("A" & j) = Range("$B$6") Or i.Range("A" & j) = Range("$B$7") Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop
End Sub
I am trying to delete duplicate values in a temporary list based on a value in a combobox. The code below loops through individual rows to check whether a value matches. It is slow.
Dim ws As Worksheet
Dim i As Long
Set ws = Sheets("TempList3")
On Error Resume Next
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If Cells(i, 2) <> Sheets("Sheet1").ComboBox2.Value Then
ws.Rows(i).EntireRow.Delete
End If
Next
Is there a way to evaluate the entire column's values against the combobox's value once and then delete all rows on a worksheet. Or perhaps there is a better way?
I used a looping Find function, it deletes the row where the value was found and then it searches again and deletes the next row it finds until it can no longer find the Combo value on the sheet:
Sub find_cell()
Dim find_cell As Range
Set ws = Sheets("TempList3")
stop_loop = False
Do Until stop_loop = True
Set find_cell = ws.Cells.Find(What:=Sheets("Sheet1").ComboBox2.Value, LookAt:=xlWhole)
If Not find_cell Is Nothing Then
ws.Rows(find_cell.Row).EntireRow.Delete
Else
stop_loop = True
End If
Loop
End Sub
Not knowing how many rows you are talking about, I used 10 thousand for my example codes. here are two examples, try the both and see what works best for you.
You can run through the column and unionize the range found, then delete the rows, for example.
See here for example workbook
Sub UnIonRng()
Dim FrstRng As Range
Dim UnIonRng As Range
Dim c As Range, s As String
s = Sheets("Sheet1").ComboBox2
Set FrstRng = Range("B:B").SpecialCells(xlCellTypeConstants, 23)
For Each c In FrstRng.Cells
If c = s Then
If Not UnIonRng Is Nothing Then
Set UnIonRng = Union(UnIonRng, c) 'adds to the range
'MsgBox UnionRng.Address 'remove later
Else
Set UnIonRng = c
End If
End If
Next c
UnIonRng.EntireRow.Delete
End Sub
Or you can try to filter the column B and delete the rows that way:
Sub FilterDeleteRow()
Dim ws As Worksheet
Dim LstRw As Long, Rng As Range, s As String, x
Set ws = Sheets("TempList3")
s = Sheets("Sheet1").ComboBox2
Application.ScreenUpdating = 0
With ws
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row
x = Application.WorksheetFunction.CountIf(.Range("B:B"), s)
If x > 0 Then
Columns("B:B").AutoFilter Field:=1, Criteria1:=s
Set Rng = .Range("B2:B" & LstRw).SpecialCells(xlCellTypeVisible)
Rng.EntireRow.Delete
.AutoFilterMode = 0
Else: MsgBox "Not Found"
End If
End With
End Sub
I would like to export data from a consolidated sheet (DATA) to multiple sheets regarding criteria.
I have a total of 13 criteria, each criteria has to be exported in its dedicated sheet.
I'm trying to optimize this macro (only 2 criteria here) because it lag out
Sub copy()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "S01" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S01*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S01Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
If sh.Name = "S02" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S02*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S02Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
Next
Application.ScreenUpdating = True
End Sub
If you have any idea, I read I can use Advanced filter but as you guess I'm new in VBA so I'm listening any tips!
Here is the Advanced Filter method you asked for:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = ["SO"&row(1:13)]
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 1 To UBound(aShts)
rCrit(2) = aShts(i, 1) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i, 1)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
The execution time should be instantaneous.
Note: this assumes that you do have 13 criteria, each starting with "SO" and that they occupy column 11 of the Data sheet. It also assumes that you already have 13 sheets named SO1... SO13 in the workbook.
UPDATE
Based on new information that the pattern of the criteria can change, please try this version instead. Note, that it assumes that the sheets already exist and that the sheet names match the criteria:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = Array("SO1", "SO2", "ADQ03", "LocS10")
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 0 To UBound(aShts)
rCrit(2) = aShts(i) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
Try using an array to set your criteria sheets:
Dim shArray As Variant
Dim shArrayString As String
Dim feuillePrincipale As Excel.Worksheet
Dim i As Long
Dim j As Long
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
j = 1
'// Create array and populate
shArray = Array("S01", "S02", "S03", "S04") '// add as required
'// Create string representation of array
shArrayString = "{"""
For i = LBound(shArray) To UBound(shArray)
shArrayString = shArrayString & shArray(i) & ""","""
Next
shArrayString = Left(shArrayString, Len(shArrayString) - 2) & "}"
'//Start loop
With feuillePrincipale
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not Evaluate("ISERROR(MATCH(" & Left(.Cells(i, 11), 3) & "," & shArrayString & ",0))") Then
.Rows(i).Copy Sheets(shArray(WorksheetFunction.Match(Left(.Cells(i, 11), 3), shArray, 0))).Cells(j, 1)
j = j + 1
End If
Next
End With
It's a bit unclear because if you follow the code you've posted - it's actually just copying and pasting data to the same sheet...
Yes, you should use an autofilter and use a special select to get only the visible cells.
If you want the loop method, you should loop through each row on sheets("DATA") and use a Select Case Statement to decide onto which sheet the data is placed.
By looping through each sheet you are adding loops that will slow it down.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim cel As Range
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each cel In feuillePrincipale.Range(feuillePrincipale.Range("A1"), feuillePrincipale.Range("A1").End(xlDown))
Select Case Left(cel.offset(,10).value, 3)
Case "S01"
j = S01Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S01Sheet.Rows(j)
Case "S02"
j = S02Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S02Sheet.Rows(j)
'Case .... keep adding select statement till you get to the last condition
Case Else
End Select
Next cel
Application.ScreenUpdating = True