I am using below code.
Sub Replace_specific_value()
'declare variables
Dim ws As Worksheet
Dim xcell As Range
Dim Rng As Range
Dim newvalue As Long
Set ws = ActiveSheet
Set Rng = ws.Range("G2:G84449")
'check each cell in a specific range if the criteria is matching and replace it
For Each xcell In Rng
xcell = xcell.Value / 1024 / 1024 / 1024
Next xcell
End Sub
Here i don't want to specify G2:G84449 , how do i tell VBA to pick all value instead of specifying range?
Watch: Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset)
Here is the standard way to get the used cell in column G starting at G2:
With ws
Set Rng = .Range("G2", .Cells(.Rows.Count, "G").End(xlUp))
End With
If the last row could be hidden use:
With ws
Set Rng = Intersect(.Range("A1", .UsedRange).Columns("G").Offset(1), .UsedRange)
End With
If Not Rng Is Nothing Then
'Do Something
End If
Reference Column Data Range (w/o Headers)
If you know that the table data starts in the first row of column G, by using the Find method, you can use something like the following (of course you can use the more explicit
With ws.Range("G2:G" & ws.Rows.Count) instead, in the first With statement).
Option Explicit
Sub BytesToGigaBytes()
Const Col As String = "G"
Dim ws As Worksheet: Set ws = ActiveSheet 'improve!
With ws.Columns(Col).Resize(ws.Rows.Count - 1).Offset(1) ' "G2:G1048576"
Dim lCell As Range: Set lCell = .Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub ' empty column
With .Resize(lCell.Row - .Row + 1) ' "G2:Glr"
.Value = ws.Evaluate("IFERROR(IF(ISBLANK(" & .Address & "),""""," _
& .Address & "/1024/1024/1024),"""")")
End With
End With
End Sub
Here's a slightly different approach that works for getting multiple columns, as long as your data ends on the same row:
set rng = application.Intersect(activesheet.usedrange, activesheet.usedrange.offset(1), range("G:G"))
This takes the intersection of the used range (the smallest rectangle that holds all data on the sheet, with the used range offset by one row (to exclude the header), with the columns you are interested in.
Related
I'm creating a macro that is formatting a collection of files and a step in this process is to delete columns that aren't required, keeping a specific set of columns.
I know I can delete columns based on their location and I have this approach implemented already ie 1,3,7 etc or A, C, G etc. But I'm conscious that the report being used might change layout or add extra columns over time and I want to ensure the required columns are kept.
Ideally this code would cycle through each column header starting at A1 until the last column and delete an entire column if the header value isn't found in a list. This list will be an array captured from a range in one of the sheets in the workbook.
List = {Blue, Green, Orange}
Original Table
Blue
Red
Green
Orange
Black
row
row
row
row
row
Formatted Table
Blue
Green
Orange
row
row
row
Does anyone have any suggestions on the approach I could take to get this working or if it's even possible? Any help would be greatly appreciated
You might profit from the following approach by reordering a datafield array via Application.Index which allows even to move the existing columns to any new position.
Note: this flexible solution can be time consuming for greater data sets,
where I would prefer other ways you can find in a lot of answers at SO.
Sub ReorderColumns()
Const headerList As String = "Blue,green,Orange"
'a) define source range
Dim src As Range
Set src = Tabelle3.Range("A1:E100")
'b) define headers
Dim allHeaders: allHeaders = src.Resize(1).Value2
Dim newHeaders: newHeaders = Split(headerList, ",")
'c) get column positions in old headers
Dim cols
cols = getCols(newHeaders, allHeaders)
'd) define data
Dim data As Variant
data = src.Value2
'e) reorder data based on found column positions
data = Application.Index(data, Evaluate("row(1:" & UBound(data) & ")"), cols)
'f) overwrite source data
src = vbNullString ' clear
src.Resize(UBound(data), UBound(data, 2)) = data
End Sub
Help function getCols()
Function getCols(individualHeaders, allHeaders)
'Purp: get 1-based column numbers of found headers via Match
getCols = Application.Match(individualHeaders, allHeaders, 0) ' 1-based
End Function
Please, test the next code. It is compact and fast enough. It will build the columns to be deleted range using Application.Match for the two involved arrays (the existing headers one and the ones to be kept). This code assumes that the headers exist in the first row of the processed sheets, starting from A:A column (If starting from a different column, the code can be adapted:
Sub DeleteColunsNotInArrayDel()
Dim sh As Worksheet, arrStay, lastCol As Long, arrH, arrCols, rngDel As Range
Set sh = ActiveSheet 'use here the sheet you need to process
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column 'last column on the first row
arrStay = Split("Blue,Green,Orange", ",") 'the headers to not be deleted array
arrH = Application.Transpose(Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2)) 'existing headers array
arrCols = Application.IfError(Application.match(arrH, arrStay, 0), "xx") 'match the two arrays and place "xx" where no match has been found
makeColsRng(arrCols).Delete 'delete the columns range, at once
End Sub
Function makeColsRng(arr) As Range
Dim i As Long, colL As String, strAddr As String
For i = LBound(arr) To UBound(arr) 'iterate between the matched arrays array
If arr(i) = "xx" Then 'for the not matching case:
colL = Split(cells(1, i).Address, "$")(1) 'extract the letter of the respective column
strAddr = strAddr & colL & "1," 'build the string of the columns to be deleted range
End If
Next i
Set makeColsRng = Range(left(strAddr, Len(strAddr) - 1)).EntireColumn 'return the necessary range
End Function
In case of headers not starting from the first sheet column, the function can easily be adapted by adding a new parameter (the first column number) to be added when the range to be deleted is built.
The above suggested solution is a fancy one, just for the sake of showing the respective approach, which is not too often used. It may have a limitation of the range building, in case of a string bigger than 254 digits, No error handling for the case of everything matching (even, easy to be added). The next version is standard VBA, compact, more reliable, faster and easier to be understood:
Sub DeleteColunsRangeNotInArray()
Dim sh As Worksheet, arrStay, lastCol As Long, rngH As Range, rngDel As Range, i As Long
Set sh = ActiveSheet
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column'last column on the first row
arrStay = Split("Blue,Green,Orange", ",") 'the headers to not be deleted array
Set rngH = sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)) 'existing headers range
For i = 1 To rngH.Columns.count
If IsError(Application.match(rngH(i).Value, arrStay, 0)) Then 'if not a match in arrStay:
addToRange rngDel, rngH(i) 'build a Union range
End If
Next i
'delete the not necessary columns at once:
If Not rngDel Is Nothing Then rngDel.EntireColumn.Delete
End Sub
Private Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
Dynamic Named Range
I think a dynamic named range is an excellent choice for storing and retrieving your required columns. Please see the link I provided from https://exceljet.net/ to setup your dynamic named range.
Generic formula =$A$2:INDEX($A:$A,COUNTA($A:$A))
Regular Expression Approach
After reading in your named range, one approach for testing your columns is using regular expressions. To use this you will need to set a library reference to Microsoft VBScript Regular Expressions 5.5. The pipe character | represents an or statement, so we can join our array using that delimiter.
Deleting Ranges in loops
When deleting columns or rows within a loop, the best approach I have found is to union the ranges together in a variable and execute the deletion in one go. This helps performance and it prevents errors from deleting ranges the loop is working on.
I do this so often that I created a custom function for this UnionRange
' Helper function that allows
' concatinating ranges together
Public Function UnionRange( _
ByRef accumulator As Range, _
ByRef nextRange As Range _
)
If accumulator Is Nothing Then
Set UnionRange = nextRange
Else
Set UnionRange = Union(accumulator, nextRange)
End If
End Function
Putting it all together
Below is my implementation of what your code could look like, just make sure to first:
Create a Dynamic Named Range and populate with your required headers
Add Microsoft VBScript Regular Expressions 5.5 reference
Update Sheet1 to whatever sheet your table exists (possibly change logic for finding header row based on your needs)
' Need Regular Expressions Referenced in order to work!
' #libraryReference {Microsoft VBScript Regular Expressions 5.5}
Public Sub DemoDeletingNonRequiredColumns()
' Make sure to create a named range
' otherwise this section will fail. In this
' example the named range is `RequiredColumns`
Dim requiredColumns() As Variant
requiredColumns = Application.WorksheetFunction.Transpose( _
Range("RequiredColumns").Value2 _
)
' To test if the column is in the required
' columns this method uses regular expressions.
With New RegExp
.IgnoreCase = True
' The pipe charactor is `or` in testing.
.Pattern = Join(requiredColumns, "|")
Dim headerRow As Range
' This example uses `Sheet1`, but update to
' the actual sheet you are using.
With Sheet1
Set headerRow = .Range("A1", .Cells(1, Columns.Count).End(xlToLeft))
End With
Dim column As Range
For Each column In headerRow
' If the column name doesn't match the
' pattern, then concatenate it to the
' toDelete range.
If Not .Test(column.Value2) Then
Dim toDelete As Range
Set toDelete = UnionRange(toDelete, column.EntireColumn)
End If
Next
End With
' toDelete is used as it provides better performance
' and it also prevents errors when deleting columns
' while looping.
If Not toDelete Is Nothing Then
toDelete.Delete
Set toDelete = Nothing
End If
End Sub
Delete Columns Not In a List
Option Explicit
Sub DeleteIrrelevantColumns()
' Source - the worksheet containing the list of headers.
Const sName As String = "Sheet2"
Const sFirstCellAddress As String = "A2"
' Destination - the worksheet to be processed.
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim sData() As Variant
With sfCell
Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
sData = .Resize(slCell.Row - .Row + 1).Value
End With
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
sDict.CompareMode = vbTextCompare
Dim sValue As Variant
Dim sr As Long
For sr = 1 To UBound(sData)
sValue = sData(sr, 1)
If Not IsError(sValue) Then ' exclude error values
If Len(sValue) > 0 Then ' exclude blanks
sDict(sValue) = Empty ' write
End If
End If
Next sr
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim drg As Range
With dfCell
Dim dlCell As Range: Set dlCell = _
.Resize(, dws.Columns.Count - .Column + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
Set drg = .Resize(, dlCell.Column - .Column + 1)
End With
Dim dData() As Variant: dData = drg.Value
Dim dCells As Range
Dim dValue As Variant
Dim dc As Long
For dc = 1 To UBound(dData, 2)
dValue = dData(1, dc)
If sDict.Exists(dValue) Then
' If duplicate columns, keep only the left-most.
sDict.Remove dValue
Else
' Combine the irrelevant header cells into a range.
If dCells Is Nothing Then
Set dCells = drg.Cells(dc)
Else
Set dCells = Union(dCells, drg.Cells(dc))
End If
End If
Next dc
' Delete columns in one go.
If Not dCells Is Nothing Then
dCells.EntireColumn.Delete
End If
' Inform.
If sDict.Count = 0 Then
MsgBox "Irrelevant columns deleted.", vbInformation
Else
MsgBox "Irrelevant columns deleted." & vbLf & vbLf _
& "Columns not found:" & vbLf _
& Join(sDict.Keys, vbLf), vbCritical
End If
End Sub
I have a formula in Column A2.
I have a table similar to this:
Formula
Note
Datum
I am very happy because I am
Years
years old
=CONCATENATE(TEXT(C2;"dd-mm-yyyy");$D$1;E2;$F$1)
Any word, TEXT
01.04.2021
21
Autofill
Any word, TEXT 2
01.04.2021
25
I want to transfer it and use it automatically for the whole column. However, I tried possible and impossible ways to do it, but none of them worked. I also looked at forums such as here:
I don't have all the data filled in the table, so I want "excel" to look for the last row in which the record is and try to calculate the formula and return it to the last cell in column A.
Thank you in advance for all the help
(The formula joins the text together) =CONCATENATE(TEXT(C2;"dd-mm-yyyy");$D$1;E2;$F$1)
Sub AutofilCol()
' Apply to the entire column Autofill
Range("A1").Offset(1, 0).Activate
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(TEXT(RC[2],""dd-mm-yyyy""),R1C4,RC[4],R1C6)"
' AutoFill
Selection.AutoFill Destination:=Range("A2:A").End(xlDown).Row
ActiveCell.EntireColumn.AutoFit
End Sub
It looks like this is what you want to do:-
Sub AutofillCol()
Dim Rl As Long ' last used row in column C
Dim Rng As Range
Rl = Cells(Rows.Count, "C").End(xlUp).Row
Set Rng = Range(Cells(2, "A"), Cells(Rl, "A"))
Rng.FormulaR1C1 = "=CONCATENATE(TEXT(RC[2],""dd-mm-yyyy""),R1C4,RC[4],R1C6)"
End Sub
Copy Formulas (Defining a Range)
In this case, there is no need to Activate (or Select) anything neither is the use of AutoFill (FillDown).
Let's say the first solution is the most flexible (reliable) but also the most complex. To better understand it, see the ranges at the various stages of the code printed in the Immediate window (CTRL+G). The flexibility is in the option to use any first cell address e.g. C5, D10, etc. and it will still work.
Depending on your data, you might easily get away with the remaining two solutions.
I didn't include any solution using End since you got that covered by another post.
Option Explicit
Sub copyFormulas()
Const First As String = "A1"
Dim ws As Worksheet: Set ws = ActiveSheet
Dim fCell As Range ' Last Cell in First Row Range
Dim frg As Range ' First Row Range of Table Range
With ws.Range(First)
Set fCell = .Resize(, .Worksheet.Columns.Count - .Column + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If fCell Is Nothing Then Exit Sub
Set frg = .Resize(, fCell.Column - .Column + 1)
Debug.Print "First", fCell.Address, frg.Address
End With
Dim tCell As Range ' Last Cell in Table Range
Dim trg As Range ' Table Range
With frg
Set tCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
Set trg = .Resize(tCell.Row - .Row + 1)
End With
Debug.Print "Table", tCell.Address, trg.Address
Dim drg As Range ' Destination Range
Set drg = trg.Columns(1).Resize(trg.Rows.Count - 1).Offset(1)
Debug.Print "Destination", drg.Address
drg.FormulaR1C1 = "=CONCATENATE(TEXT(RC[2],""dd-mm-yyyy""),R1C4,RC[4],R1C6)"
' Or.
'drg.Formula = "=CONCATENATE(TEXT(C2,""dd-mm-yyyy""),$D$1,E2,$F$1)"
End Sub
Sub copyFormulasUsedRange()
With ActiveSheet.UsedRange.Columns(1)
.Resize(.Rows.Count - 1).Offset(1).FormulaR1C1 _
= "=CONCATENATE(TEXT(RC[2],""dd-mm-yyyy""),R1C4,RC[4],R1C6)"
End With
End Sub
Sub copyFormulasCurrentRegion()
With ActiveSheet.Range("A1").CurrentRegion.Columns(1)
.Resize(.Rows.Count - 1).Offset(1).FormulaR1C1 _
= "=CONCATENATE(TEXT(RC[2],""dd-mm-yyyy""),R1C4,RC[4],R1C6)"
End With
End Sub
I want to select the content of my worksheet after the character occurrence in the row.
The code I have been using so far selects all the stuff after the offset.
Sub Selection ()
Dim Target_Start As Range, Target_End As Range
Dim n as long
Set Target_Start = work.Cells.Find("X", SearchOrder:=xlByColumns).Offset(1)
Set Target_End = Target_Start.End(xlDown).End(xlToRight)
work.Range(Target_Start, Target_End).Select
'Selection.EntireRow.Clear
End Sub
What should I alter in my code?
Select Used Range After a Cell
If you want to allow a lower-case "X" then replace True with False (MatchCase).
Note that this solution will include row 15 in your image which may be only formatted (borders, no values), because we are using Used Range. If you don't like that, you will have to use another way to define the range.
Option Explicit
Sub selectAfter()
Const sString As String = "X"
With work.UsedRange
Dim rg As Range
Set rg = .Find(sString, .Cells(.Rows.Count, .Columns.Count), _
xlFormulas, xlWhole, xlByRows, , True)
If Not rg Is Nothing Then
Dim Offs As Long: Offs = rg.Row - .Row + 1
Set rg = .Resize(.Rows.Count - Offs).Offset(Offs)
rg.Select
End If
End With
End Sub
I have a template file that I will use to populate more files and I need to hide some rows according to what its selected, but at the same time I can't hide other rows. I can do it well if the data stay the same size all the time, but the file will be increasing and decreasing depending on the information.
I have a range of values in Column C. What I tried to do is to look for the cell value that contains "Pack" (It will be same for all files). From that cell that contains "Pack" (let's assume that is at C8 now, but can be in C30 in other file) I need to start looking for values that are not equal to the one that I have from a droplist (rowing) and hide the rows.
Maybe better explained, also I tried to do was to assign a variable that will hold the value of the droplist and just look for values that was not equal and simply hide it. Then do a .Find() to find the "Pack" word. Once it was found, get the cell address. Finally take that address and use it as a parameter in Range() as yo can see in the code that I wrote: For Each cell In Range("packR:C5") and I know that is very wrong because I can't pass that.
Dim cell As Range
Dim pack As Range
rowing = Range("A2").Value
Set pack = Range("C1:C12").Find("Pack")
Set packA = Range(pack.Address)
Set packR = packA
For Each cell In Range("packR:-end point here")
cell.EntireRow.Hidden = False
If Not IsEmpty(cell) Then
If cell.Value <> rowing Then
cell.EntireRow.Hidden = True
End If
End If
Next
I have very little vba background but with research I can understand a few. Basically the goal is to ignore all the rows in top of "Pack" and start looking from "Pack" (That need to have a cell address) to the end of the excel file. The biggest issue is to take that cell address and use it as parameter to the Range ("":"").
I think you're looking for something like this. Note the comment about specifying the other parameters of Range.Find.
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rowing As Variant
rowing = ws.Range("A2").Value
Dim pack As Range
Set pack = ws.Range("C1:C12").Find("Pack") '<--- you should specify the other parameters of Find
Dim lastCell As Range
Set lastCell = ws.Cells(ws.Rows.Count, "C").End(xlUp)
If Not pack Is Nothing Then '<--- tests to see if pack was found
Dim cell As Range
For Each cell In ws.Range(pack, lastCell)
If Not IsEmpty(cell) Then
cell.EntireRow.Hidden = (cell.Value <> rowing)
End If
Next
End If
End Sub
EDIT:
End(xlUp) will not find the true last row if rows are already hidden. To get around this, here are two options:
Unhide all rows after finding "Pack".
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rowing As Variant
rowing = ws.Range("A2").Value
Dim pack As Range
Set pack = ws.Range("C1:C12").Find("Pack") '<--- you should specify the other parameters of Find
If Not pack Is Nothing Then '<--- tests to see if pack was found
ws.UsedRange.EntireRow.Hidden = False '<--- unhide all rows so as to find the last cell properly
Dim lastCell As Range
Set lastCell = ws.Cells(ws.Rows.Count, "C").End(xlUp)
Dim cell As Range
For Each cell In ws.Range(pack, lastCell)
If Not IsEmpty(cell) Then
cell.EntireRow.Hidden = (cell.Value <> rowing)
End If
Next
End If
End Sub
Use an alternate way of finding the last cell:
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rowing As Variant
rowing = ws.Range("A2").Value
Dim pack As Range
Set pack = ws.Range("C1:C12").Find("Pack") '<--- you should specify the other parameters of Find
Dim lastCell As Range
Set lastCell = GetLastCell(ws, 3)
If Not pack Is Nothing Then '<--- tests to see if pack was found
Dim cell As Range
For Each cell In ws.Range(pack, lastCell)
If Not IsEmpty(cell) Then
cell.EntireRow.Hidden = (cell.Value <> rowing)
End If
Next
End If
End Sub
Private Function GetLastCell(ByVal ws As Worksheet, Optional ByVal colNum As Long = 1) As Range
With ws
Dim lastCell As Range
Set lastCell = .Columns(colNum).Find(What:="*", _
After:=.Cells(1, colNum), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If lastCell Is Nothing Then
Set lastCell = .Cells(1, colNum)
End If
End With
Set GetLastCell = lastCell
End Function
In various places in column E of spreadsheet "Review" I have variables that start with the word "Sustainability:" (e.g., Sustainability: a, Sustainability:B"). Each time it finds one. I want it to copy the cell that is in the same row but two columns to the right. Then I want it to paste into a different sheet (SPSE Tran), starting at B63. Each time it pastes, the destination needs to offset by 1 row so it can paste down until it finds no more "Sustainability:". The code below is a start to this but I am stuck.
The second thing I need it to do (which I don't even know where to start) is to only iterate doing this until it finds a row that says "ONLY FOR TRANSITIONS". This leads into a new section that also includes "Sustainability:" but I don't want it to copy from there.
Thank you!
Sub SubmitData()
Dim RngA As Range
Dim FirstAd As String
Dim DestAd As Range
With Sheets("Review").Range("E:E")
Set RngA = .Find(What:="Sustainability:", lookat:=xlPart)
Set DestAd = Range("B63")
If Not RngA Is Nothing Then
FirstAd = RngA.Address
Do
Range(Cell, Cell.Offset(0, 2)).Copy _
Destination:=Sheets("SPSE Tran").Range(DestAd)
Set RngA = .FindNext(RngA)
Set DestAd = DestAd.Offset(0, 1)
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd
End If
End With
End Sub
Here's your code revamped to use a filter instead of a find loop, and then it gets all the results and copies them to the destination at once:
Sub SubmitData()
Dim ws As Worksheet
Dim rngDest As Range
Dim rngStop As Range
With Sheets("SPSE Tran")
Set rngDest = .Cells(Rows.Count, "B").End(xlUp)
If rngDest.Row < 63 Then Set rngDest = .Range("B63")
End With
Set ws = Sheets("Review")
Set rngStop = ws.Columns("A").Find("ONLY FOR TRANSITIONS", , xlValues, xlPart)
With ws.Range("E1:E" & rngStop.Row)
.AutoFilter 1, "Sustainability:*"
.Offset(1, 2).Copy rngDest
.AutoFilter
End With
End Sub
How about (untested):
RngB = where you find "ONLY FOR TRANSITIONS"
RngBRow = RngB.Row
then change your Loop While .. to
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd And RngA.Row < RngBRow