How to shift columns with their properties in vba excel - excel

so i have some code that outputs this on a spreasheet:
what i want is that you see those empty columns i need them to be gone and have all the columns beside each other to save space.
so is there a way for me to check if a column is empty and if it is i need to pretty much cut and paste the next bunch of columns onto the empty ones WITH their properties such as color code and border.
any help is much appreciated, and thnx in advance. ^_^ :D

Try WorksheetFunction.CountA(Columns( *REF* )), replacing * REF * with the reference to each column (e.g. using variable and looping through)
If this = 0, the column is empty.
You can then just delete the empty columns, e.g. using If... Then in your loop.
(Have a look at:
http://analysistabs.com/excel-vba/delete-rows-columns/ for example)

Try this:
Sub DeleteColumns()
Dim rng As Range
Dim i As Long
Dim wkSht As Worksheet
Set wkSht = ThisWorkbook.Sheets("Sheet1") '--> enter your sheet name here
Set rng = wkSht.Range("A:Z") '--> set your range here
For i = rng.Columns.Count To 1 Step -1
If Application.CountA(Columns(i).EntireColumn) = 0 Then
Columns(i).Delete
End If
Next i
End Sub
You can also delete all the empty columns together using union as:
Sub DeleteColumns()
Dim rng As Range, delRng As Range
Dim i As Long
Dim wkSht As Worksheet
Set wkSht = ThisWorkbook.Sheets("Sheet2") '--> enter your sheet name here
Set rng = wkSht.Range("A:Z") '--> set your range here
For i = 1 To rng.Columns.Count
If Application.CountA(Columns(i).EntireColumn) = 0 Then
If delRng Is Nothing Then
Set delRng = Columns(i)
Else
Set delRng = Union(delRng, Columns(i))
End If
End If
Next i
delRng.Delete '--> delete all empty columns
End Sub

Related

Delete duplicate arrays based on column values across several blocks of data

I have been working on automating different parts of the process of formatting a very large data set. I am stuck on trying to automate the "remove duplicates" command across all blocks of my data:
I have blocks of data (9 columns wide, x rows long) as on the image attached. In the column called "#Point ID" are values 0-n. Some values appear once, some values appear more than once. Different blocks have different "#Point ID" columns
I would like to delete all rows in the block where the value in the "#Point ID" column has already occurred (starting from the top, moving down the rows). I would like the deleted rows removed from the blocks, so only the rows (which are blue on the image) with unique values in "#Point ID" column (green on the image) remain.
I have found VBA modules that work on a single block, but I don't know how to make it function across all my blocks. Delete rows in Excel based on duplicates in Column
I have also tried combinations of functions (inc. UNIQUE and SORTBY) without any success.
What's a function or a VBA module that works?
Use this
Public Sub cleanBlock(rng As Range)
Dim vals As Object
Set vals = CreateObject("Scripting.Dictionary")
Dim R As Range
Dim adds As Range
For Each R In rng.Rows
If (vals.exists(R.Cells(1, 2).Value)) Then
If adds Is Nothing Then
Set adds = R
Else
Set adds = Union(adds, R)
End If
Else
vals(R.Cells(1, 2).Value) = True
End If
Next R
Debug.Print (adds.Address)
If Not adds Is Nothing Then adds.Delete shift:=xlUp
Set vals = Nothing
End Sub
Public Sub test()
cleanBlock Range("b3:j20")
cleanBlock Range("l3:t20")
cleanBlock Range("y3:ad20")
End Sub
Remove Duplicates in Areas of a Range
Sub RemoveDupesByAreas()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1") ' adjust!
Dim rg As Range: Set rg = ws.UsedRange.SpecialCells(xlCellTypeConstants)
Dim aCount As Long: aCount = rg.Areas.Count
Dim arg As Range, a As Long
For a = aCount To 1 Step -1
Set arg = rg.Areas(a)
Debug.Print a, arg.Address(0, 0)
' Before running the code with the next line, in the Immediate
' window ('Ctrl+G'), carefully check if the range addresses
' match the areas of your data. If they match, uncomment
' the following line to apply remove duplicates.
'arg.RemoveDuplicates 2, xlYes
Next a
MsgBox "Duplicates removed.", vbInformation
End Sub
Find and FindNext feat. CurrentRegion
Sub RemoveDupesByFind()
Const SEARCH_STRING As String = "Source.Name"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1") ' adjust!
Dim rg As Range: Set rg = ws.UsedRange
Dim fCell As Range: Set fCell = rg.Find( _
SEARCH_STRING, , xlFormulas, xlWhole, xlByRows, xlPrevious)
If fCell Is Nothing Then
MsgBox """" & SEARCH_STRING & """ not found.", vbCritical
Exit Sub
End If
Dim FirstAddress As String: FirstAddress = fCell.Address
Do
fCell.CurrentRegion.RemoveDuplicates 2, xlYes
Set fCell = rg.FindNext(fCell)
Loop Until fCell.Address = FirstAddress
MsgBox "Duplicates removed.", vbInformation
End Sub
Another way, maybe something like this :
Sub test()
Dim rgData As Range
Dim rg As Range: Dim cell As Range
Dim rgR As Range: Dim rgDel As Range
Set rgData = Sheets("Sheet1").UsedRange 'change as needed
Set rgData = rgData.Resize(rgData.Rows.Count - 1, rgData.Columns.Count).Offset(1, 0)
For Each rg In rgData.SpecialCells(xlConstants).Areas
For Each cell In rg.Columns(2).Cells
Set rgR = cell.Offset(0, -1).Resize(1, rg.Columns.Count)
If cell.Value = 0 And cell.Offset(1, 0).Value <> 0 And cell.Offset(0, 1).Value = 0 And cell.Address = rg.Columns(2).Cells(1, 1).Address Then
Else
If Application.CountIf(rg.Columns(2), cell.Value) > 1 And cell.Offset(0, 1).Value = 0 Then
If rgDel Is Nothing Then Set rgDel = rgR Else Set rgDel = Union(rgDel, rgR)
End If
End If
Next cell
Next rg
rgDel.Delete Shift:=xlUp
End Sub
The code assumed that there'll be no blank cell within each block and there will be full blank column (no value at all) between each block. So it sets the usedrange as rgData variable, and loop to each area/block in rgData as rg variable.
Within rg, it loop to each cell in rg column 2, and check if the count of the looped cell value is > 1 and the value of the looped cell.offset(0,1) is zero, then it collect the range as rgDel variable.
Then finally it delete the rgDel.
If you want to step run the code, try to add something like this rg.select ... rgR.select .... after the variable is set. For example, add rgDel.select right before next area, so you can see what's going on.
The code assume that :
the first value right under "#Point" in each block will be always zero. It will
never happen that the value is other than zero.
the next value (after that zero value) is maybe zero again or maybe one.
if there are duplicates (two same value) in column #Point then in column X, it's not fix that the first one will always have value and the second one will always zero value.
If the data is always fix that the first one will always have value and the second one will always zero value (if there are duplicate), I suggest you to use Mr. VBasic2008 or Mr. wrbp answer. Thank you.

Stack different columns into one column on a different worksheet

I want to copy all filled cells starting from C5 to column F of a different worksheet.
I referred to another post: Excel - Combine multiple columns into one column
Modified the code based on my needs.
Sub CombineColumns()
Dim Range1 As Range, iCol As Long, Range2 As Range, Check As Range, wks As Worksheets
Set Range1 = wks("T(M)").Range(Cells(5, 3), Cells(Cells(5, 3).End(xlDown).Row, Cells(5, 3).End(xlToRight).Column))
Set Check = wks("csv").Range("F1")
If IsEmpty(Check.Value) = True Then
Set Range2 = Check
Else
LastRow = wks("csv").Range("F" & Rows.Count).End(xlUp).Row
Set Range2 = wks("csv").Cells(LastRow, 6).Offset(1, 0)
End If
For iCol = 3 To Range1.Columns.Count
wks("T(M)").Range(Cells(5, iCol), Cells(Range1.Columns(iCol).Rows.Count, iCol)).Copy
wks("csv").Range2.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Next iCol
End Sub
But I kept getting the error message
"object doesn't support this method or property"
at the step of pasting. After I tried to qualify all the ranges, It says I didn't set the object variable.
Thank you so much for the help!
How about this?
Sub Transposes()
' Example just for hardcoded data
Dim inputRange As Range
Set inputRange = Sheets("Sheet1").Range("C5:F10").SpecialCells(xlCellTypeConstants)
Dim outputCell As Range
Set outputCell = Sheets("Sheet2").Range("A1")
Dim cell As Range
For Each cell In inputRange
Dim offset As Long
outputCell.offset(offset).Value = cell.Value
offset = offset + 1
Next cell
End Sub
Set the last row in ColumnF to be whatever you want, and if that changes dynamically, just use any one of the multiple techniques out there to find the last cell you need to copy/paste.

Create a named range based on a value in another column not included in range

I have a data set, 10 columns wide, with an ever increasing number of rows.
In column C I have a set of features, e.g. "Search" that will have a few rows corresponding to it; ""Filter" that will have a few rows corresponding to it and so on. However, these could be in any order, so I could have some "Search" features and then some "Filter" features and then some more "Search" features...
I need to create a named range for selected cells in columns D:F where the value in C is the feature I require. This would be for example a named range called "T1" that goes from D3:F6 and maybe D71:F71 for all the "Search" features, but not the "Filter" features.
I have tried using Offset and Count in the Name Manager. But ideally, I need to use VBA in my already existing macro so I don't need to go in and change the Named Ranges every time a new row is added.
Ideally the code would be along the lines of...
If column C contains the word "Filter", make a named range for the three columns to the right of it, every time the word "Filter" occurs.
I used Offset and Count in the name manager:
=OFFSET(Features!$D$3, 0, 0, COUNTA(Features!$D$3:$D$9), COUNTA(Features!$D$3:$F$3))
Sub mySub()
Dim Features As Worksheet
Dim myNamedRange As Range
Dim myRangeName As String
Set Features = ThisWorkbook.Worksheets("Search")
If Range.("C") is "Search"
Set mRangeName= myWorksheet.Range("D:F")
myRangeName = "Search"
ThisWorkbook.Names.Add Name:=Search, RefersTo:=myNamedRange
End Sub
Any help would be greatly greatly appreciated. I hope I have clarified the problem enough.
If I understand correctly then you could try something like the following:
Sub test()
Dim featuresRng As Range
Dim rng As Range
Dim sht As Worksheet
Dim counter As Long
Dim cell As Range
Set sht = ThisWorkbook.Worksheets("Name of your worksheet")
Set featuresRng = sht.Range(sht.Range("C1"), sht.Range("C" & sht.Rows.Count).End(xlUp)) 'dynamically set the range of features
counter = 0 'this counter will help us avoid Union(Nothing, some range), which would give an error
For Each cell In featuresRng 'loop through the range of features
If cell.Value = "search" Then
counter = counter + 1
If counter = 1 Then
Set rng = sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))
Else
Set rng = Union(rng, sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))) 'build the range
End If
End If
Next cell
Debug.Print rng.Address
sht.Names.Add "Something", rng
End Sub
The code above, loops through the range of features and whenever a cell whose value is "search" is found, it adds the corresponding D, E and F cells in a range. In the end you have a total range which you can name whatever you want.
For example, if you have the following set-up:
Then what you'll get is this:
So the resulting range address would be $D$1:$F$2,$D$8:$F$8,$D$10:$F$12,$D$15:$F$19
Now, if you want individual named ranges to be created every time the keyword is found you can modify the code accordingly like so:
Sub test2()
Dim featuresRng As Range
Dim rng As Range
Dim sht As Worksheet
Dim counter As Long
Dim cell As Range
Set sht = ThisWorkbook.Worksheets("Name of your worksheet")
Set featuresRng = sht.Range(sht.Range("C1"), sht.Range("C" & sht.Rows.Count).End(xlUp)) 'dynamically set the range of features
counter = 0
For Each cell In featuresRng
If cell.Value = "search" Then
counter = counter + 1
Set rng = sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))
sht.Names.Add "Something" & counter, rng
End If
Next cell
End Sub

How can I implement a query comparing ID's in different sheets with printing of confirmation in corresponding line?

Let's assume I have a workbook with 2 worksheets.(There are more but this doesn't matter for the question)
Sheet 1 and Sheet 2 each hold 2 columns that look like this:
Sheet 1: ID Open job
Sheet 2: … ID
I would like to check if the ID in Sheet 1 in the first row can be found anywhere in the second column in Sheet 2. If the ID is found, the application should print "YES" in the first respectively the corresponding line of the original search-ID under "Open job"; if the ID is not found,"NO" should be printed.
Since I'm new to coding I don't really have a clue how to get this done.
I have a structure of pseudo-code and some "real" elements for better problem understanding.
Here is the pseudo code:
Sub Query_if_ID_matches_print_YES/NO
'Lets assume there are headers in the first line of both worksheets'
For each Cell in Sheets ("Sheet1").Range("A2:A500")
If Cell("A2").Value = Value 'Should be an integer'
Search for Value in ("Sheet2").Range("B2:B500")
If Value found in ("Sheet2").Range("B2:B500")
Print Value = "YES" in Sheets ("Sheet1").Range("B2")
Else Print Value = "NO" in Sheets ("Sheet1").Range("B2")
End If
Next Cell
End for
End Sub
I hope I stated the problem in an understandable way.
Thanks for any help in advance:)
If I've understood your question correctly this might work:
Sub Query()
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim rng As Range
Dim objDic As Object
Set wks1 = ThisWorkbook.Worksheets("Sheet1")
Set wks2 = ThisWorkbook.Worksheets("Sheet2")
Set rng1 = wks1.Range("A2:A500")
Set rng2 = wks2.Range("B2:B500")
Set objDic = CreateObject("Scripting.Dictionary")
For Each rng In rng2
If objDic.Exists(rng.Value) = False Then
objDic.Add rng.Value, rng.Address
End If
Next rng
For Each rng In rng1
If objDic.Exists(rng.Value) Then
rng.Offset(0, 1).Value = "YES"
Else
rng.Offset(0, 1).Value = "NO"
End If
Next rng
Set objDic = Nothing
End Sub

Excel VBA Range Finding and Deletion

I have a couple of questions regarding VBA which I hope you folks can help me with. I'm a very new coder to VBA, so any help you can provide is very much appreciated.
Objective - Remove all rows from "cellRange" if a similar value is found in "valueRange"
Code so far
Sub DeleteRows()
Set valueRange = Worksheets("Delete Rows").Range("A4:A65000")
Set cellRange = Worksheets("Load File").Columns(Worksheets("Delete Rows").Range("F1").Value)
For Each Cel In cellRange.Cells
For Each Value In valueRange.Cells
If Cel.Value = Value.Value Then
Cel.EntireRow.Delete
End If
Next Value
Next Cel
End Sub
Problem 1: valueRange doesn't always have all 65000 rows populated. How can I only make it so that the range only grabs those from A4:(until it hits an empty column)
Problem 2: Similar to problem 1, but the cellRange
Problem 3: Whenever a row is deleted, it seems to affect how the range is set. Meaning that if it deletes row #10 in, then the loop goes to row#11 without checking row #10 again. How can I tell the look to do a second pass or to go through the file again.
P1: Two options here
a) if the Cel.Value is Empty, Exit For
b) proper range selection, refer to this guy here: Excel: Selecting all rows until empty cell
P2: Same as above
P3: As For-Each can't go "backwards" the best you can do is
a) Don't delete the row but store it's number instead e.g. in a Long array, then add a For-Next and delete the "marked" rows like:
For x = UBound(myLongArray)-1 To 0 Step -1
cel(x).EntireRow.Delete
Next x
b) instead of For-Each, store the number of rows (via the ROWS function) in a variable and go through the rows with a 'Step -1' loop
As others mention, you have to step backwards when deleting.
Also, I modified to avoid unnecessary iteration over each cell in ValueRange, instead use the Match() function to check if Cel.Value exists in ValueRange.
Sub DeleteRows()
Dim r as Long
Dim valueRange as Range, cellRange as Range
Dim Cel as Range
Set valueRange = Worksheets("Delete Rows").Range("A4:A65000").End(xlUp) '<~~ Get the last unused row
Set cellRange = Worksheets("Load File").Columns(Worksheets("Delete Rows").Range("F1").Value)
For r = cellRange.Cells.Count to 1 Step -1 '<~~ When deleting rows you must step backwards through the range to avoid the error you are encountering.'
Set Cel = cellRange.Cells(r)
'Check to see if Cel.Value exists in the ValueRange using the "Match" function'
If Not IsError(Application.Match(Cel.Value,ValueRange,False) Then
Cel.EntireRow.Delete
End If
Next r
End Sub
Here you go.
' Declare your variables to get intellisense
Dim rngDelete As Range
Dim cellRange As Range
Dim valueRange As Range
' Get only the rows with data
Set valueRange = Worksheets("Delete Rows").Range("A4")
If valueRange.Offset(1, 0) <> "" Then
Set valueRange = Worksheets("Delete Rows").Range(valueRange, valueRange.End(xlDown))
End If
' Get only the rows with data
Set cellRange = Worksheets("Load File").Cells(Worksheets("Delete Rows").Range("F1").value,1)
If cellRange.Offset(1, 0) <> "" Then
Set cellRange = Worksheets("Load File").Range(cellRange, cellRange.End(xlDown))
End If
Dim cel As Range
Dim value As Range
' make cel your outer since it has more rows
For Each cel In cellRange.Cells
For Each value In valueRange.Cells
If value.value = cel.value Then
' Don't delete it yet but store it in a list
If rngDelete Is Nothing Then
Set rngDelete = cel.EntireRow
Else
Set rngDelete = Union(rngDelete, cel.EntireRow)
End If
' no need to look further
Exit For
End If
Next
Next
' Wipe them out all at once
rngDelete.Delete

Resources