I need to:
1. Find a column containing the word 'target' in header. (from the range P1 to QI1 )
2. Delete all other column without 'target' in its header.
Code:
Sub Cleanup()
Dim rng As Range
With ActiveSheet.Range("P1:QI1")
Set rng = ActiveSheet.Range("P1:QI1").Find(What:="target", _
LookAt:=xlPart, MatchCase:=False)
Do While Not rng Is Nothing
rng.EntireColumn.Delete
Set rng = .FindNext
Loop
End With
End Sub
the code above is deleting all the column with the word 'target'. i would like it the other way around. i need to keep those columns.
thanks in advance.
TESTED - enjoy :)
Sub test()
Dim erange As Range
Dim str As String
For Each erange In Range("A1:E1")
If not erange.Value = "Target" Then
' If InStr(erange.Value, "Target") <> 0 Then
If str <> "" Then
str = str & "," & erange.EntireColumn.Address
Else
str = erange.EntireColumn.Address
End If
End If
Next erange
str = Replace(str, "$", "")
' Delete columns in single shot
Range(str).Delete
End Sub
Related
Trying to make a VBA Code which performs the following action.
That If Sheet1.Range("B7").Value = 2002_2550 or Text or Number
then Find that value in Sheet14.Range("A:A") If that number Matches then then copy the same cell of Col"B"
and then paste copied value in to Sheet4.Range("f11:f100") till the ColE used range.
I have tried with below code but nothing happened.
Sub Match()
Sheet4.Range("f11:f100").Value = WorksheetFunction.Match(Sheet1.Range("B7").Value, Sheet14.Range("A2), 0)
End Sub
Make this as well but nothing is working.
Sub FindStr()
Dim rFndCell As Range
Dim stFnd As String
Dim fCol As Integer
stFnd = Sheet1.Range("B7").Value
Set rFndCell = Sheet14.Range("A:A").Find(stFnd, LookIn:=xlValues)
If Not rFndCell Is Nothing Then
fCol = rFndCell.Column
Sheet14.Range("B3:B33").Copy Sheet4.Range("F100:F100")
Else 'Can't find the item
MsgBox "No Find"
End If
End Sub
Please, try the next code line:
Dim lastR4 As Long
lastR4 = Sheet4.Range("E" & rows.count).End(xlUp).row 'last row on E:E col
Sheet4.Range("F11:F" & lastR4).Value = Sheet14.Range("A" & _
WorksheetFunction.match(Sheet1.Range("B7").Value, Sheet14.Range("A:A"), 0)).Offset(0, 1)
I have a column with data taken from CSV file, the data contain the dot I need to remove. When I want to replace „.“(dot) with „“ (nothing) with VBA I have a wrong result. All numbers smaller than 1000 replace the comma, I have for example 122,49 and the result is 12249 which is wrong.
I tried several VBA codes, non of them worked.
If you can help me it would be great. I tried all options with formats..
Thank you.
2.078,00 -> 2078,00 ok
122,49 -> 12249 ko
328,28 -> 32828 ko
11.192,34 -> 11192,34 ok
Sub TEST()
Dim i As String
Dim k As String
i = "."
k = ""
Columns("P:P").Replace what:=i, replacement:=k, lookat:=xlPart, MatchCase:=False
End Sub
Actually this is a bug in Excel! It only happens in VBA. If you do the same replace from the user interface it works. The same from a recorded macro fails. So obviously a bug.
I recommend to read all the values into an array, then replace and then write them back. This way the error does not occur and using arrays is even faster than using ranges.
Option Explicit
Sub TEST()
Dim i As String
Dim k As String
i = "."
k = ""
Dim LastRow As Long 'find last used row (to reduce processed cells)
LastRow = Cells(Rows.Count, "P").End(xlUp).Row
Dim ReplaceValues() As Variant 'read all values into array
ReplaceValues = Range("P1:P" & LastRow).Value
Dim iRow As Long 'replace
For iRow = LBound(ReplaceValues) To UBound(ReplaceValues)
ReplaceValues(iRow, 1) = Replace(ReplaceValues(iRow, 1), i, k)
Next iRow
'write all values from array back into cells
Range("P1:P" & LastRow).Value = ReplaceValues
End Sub
Or, use Application.Substitute:
Sub Test()
Dim lr As Long
Dim arr As Variant
lr = Cells(Rows.Count, "P").End(xlUp).Row
arr = Range("P1:P" & lr).Value
Range("P1:P" & lr).Value = Application.Substitute(arr, ".", "")
End Sub
I'm not sure if I exactly understand your requirements, but see if this is doing what you want.
Function RemovePeriods(ByVal number As String) As String
RemovePeriods= Replace(number, ".", ",")
RemovePeriods= Replace(Left$(RemovePeriods, Len(number) - 3), ",", "") & Right$(RemovePeriods, 3)
End Function
'run from here
Sub Example()
Debug.Print RemovePeriods("2.078,00")
Debug.Print RemovePeriods("122,49")
Debug.Print RemovePeriods("328,28")
Debug.Print RemovePeriods("11.192,34")
End Sub
Output
2078,00
122,49
328,28
11192,34
Give this a try:
Sub dotKiller()
For Each cell In Intersect(Range("P:P"), ActiveSheet.UsedRange)
v = cell.Text
If InStr(v, ".") > 0 Then
cell.Clear
cell.NumberFormat = "#"
cell.Value = Replace(v, ".", "")
End If
Next cell
End Sub
If the cell does not contain a dot it will not be changed.
Before:
and after:
Try this
Sub Test()
Columns("P:P").Replace What:=Application.DecimalSeparator, Replacement:="", LookAt:=xlPart, MatchCase:=False
End Sub
Or manually File >> Options >> Advanced >> Uncheck (Use system separators)
I want to search in a column and find a string. However, there are several cells with that string and I want to return an array that contains all row position.
Dim r As Range
Set r = Sheets("Sheet3").columns(3).Find(What:="TEST", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
this return only the first row, but not all.
How can I return all of rows that contain "TEST"?
Thanks.
This should do the trick...
It will loop through Column 3 of Sheet3 to produce an array containing the row numbers of every occurrence of TEXT. Based on the options used in your example, it is case sensitive and must occupy the whole cell.
Sub demo_FindIntoArray()
Const searchFor = "TEST" 'case sensitive whole-cell search term
Const wsName = "Sheet3" 'worksheet name to search
Const colNum = 3 'column# to search
Dim r As Range, firstAddress As String, strTxt As String, arrRows
With Sheets("Sheet3").Columns(3)
Set r = .Find(searchFor, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not r Is Nothing Then
firstAddress = r.Address
Do
If strTxt <> "" Then strTxt = strTxt & ","
strTxt = strTxt & r.Row
Set r = .FindNext(r)
Loop While Not r Is Nothing And r.Address <> firstAddress
End If
End With
If strTxt <> "" Then
arrRows = Split(strTxt,",")
MsgBox "Found " & UBound(arrRows)+1 & " occurrences of '" & searchFor & "':" & vbLf & vbLf & strTxt
Else
MsgBox "'" & searchFor & "' was not found."
End If
'[arrRows] is now an array containing row numbers
End Sub
It works by first building a string with a comma separated list of values, and then using the Split function to split it into an array.
This will unionize the ranges that equal "Test",
Sub SelectA1()
Dim FrstRng As Range
Dim UnionRng As Range
Dim c As Range
Set FrstRng = Range("C:C").SpecialCells(xlCellTypeConstants, 23)
For Each c In FrstRng.Cells
If LCase(c) = "test" Then
If Not UnionRng Is Nothing Then
Set UnionRng = Union(UnionRng, c) 'adds to the range
Else
Set UnionRng = c
End If
End If
Next c
UnionRng.Select ' or whatever you want to do with it.
End Sub
You don't indicate what you want to do with the results. However, you can return an array of the row numbers containing the word "TEST" with a worksheet formula:
Case Insensitive:
=AGGREGATE(15,6,SEARCH("TEST",$C:$C)*ROW($C:$C),ROW(INDIRECT("1:" & COUNTIF($C:$C,"*TEST*"))))
Case Sensitive:
=AGGREGATE(15,6,FIND("TEST",$C:$C)*ROW($C:$C),ROW(INDIRECT("1:" & SUMPRODUCT(--ISNUMBER(FIND("TEST",$C:$C))))))
Case Insensitive; cell = test (eg entire cell contents):
=AGGREGATE(15,6,1/($C:$C="test")*ROW($C:$C),ROW(INDIRECT("1:"&COUNTIF($C:$C,"test"))))
If you want to use this array for something else, such as to return the contents of the rows where the third column = "test", you could also do this with a filter, either in VBA or on the worksheet.
There are many different appropriate solutions, depending on what you are going to do with the results of these row numbers.
I'm trying to write a macro where if there is a cell with the word "TOTAL" then it will input a dash in the cell below it. For example:
In the case above, I would want a dash in cell F7 (note: there could be any number of columns, so it will always be row 7 but not always column F).
I'm currently using this code, but it's not working and I can't figure out why.
Dim celltxt As String
Range("C6").Select
Selection.End(xlToRight).Select
celltxt = Selection.Text
If InStr(1, celltext, "TOTAL") > 0 Then
Range("C7").Select
Selection.End(xlToRight).Select
Selection.Value = "-"
End If
Help would be appreciated. Hopefully I'm not doing something stupid.
This will loop through all cells in a given range that you define ("RANGE TO SEARCH") and add dashes at the cell below using the Offset() method. As a best practice in VBA, you should never use the Select method.
Sub AddDashes()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("RANGE TO SEARCH")
For Each cel In SrchRng
If InStr(1, cel.Value, "TOTAL") > 0 Then
cel.Offset(1, 0).Value = "-"
End If
Next cel
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(Target, Range("C6:ZZ6")) Is Nothing Then
If InStr(UCase(Target.Value), "TOTAL") > 0 Then
Target.Offset(1, 0) = "-"
End If
End If
End Sub
This will allow you to add columns dynamically and automatically insert a dash underneath any columns in the C row after 6 containing case insensitive "Total". Note: If you go past ZZ6, you will need to change the code, but this should get you where you need to go.
This does the same, enhanced with CONTAINS:
Function SingleCellExtract(LookupValue As String, LookupRange As Range, ColumnNumber As Integer, Char As String)
Dim I As Long
Dim xRet As String
For I = 1 To LookupRange.Columns(1).Cells.Count
If InStr(1, LookupRange.Cells(I, 1), LookupValue) > 0 Then
If xRet = "" Then
xRet = LookupRange.Cells(I, ColumnNumber) & Char
Else
xRet = xRet & "" & LookupRange.Cells(I, ColumnNumber) & Char
End If
End If
Next
SingleCellExtract = Left(xRet, Len(xRet) - 1)
End Function
Dim celltxt As String
Range("C6").Select
Selection.End(xlToRight).Select
celltxt = Selection.Text
If InStr(1, celltext, "TOTAL") > 0 Then
Range("C7").Select
Selection.End(xlToRight).Select
Selection.Value = "-"
End If
You declared "celltxt" and used "celltext" in the instr.
Is this what you are looking for?
If ActiveCell.Value == "Total" Then
ActiveCell.offset(1,0).Value = "-"
End If
Of you could do something like this
Dim celltxt As String
celltxt = ActiveSheet.Range("C6").Text
If InStr(1, celltxt, "Total") Then
ActiveCell.offset(1,0).Value = "-"
End If
Which is similar to what you have.
Requirement:
Find a cell containing the word TOTAL then to enter a dash in the cell below it.
Solution:
This solution uses the Find method of the Range object, as it seems appropriate to use it rather than brute force (For…Next loop).
For explanation and details about the method see Range.Find method (Excel)
Implementation:
In order to provide flexibility the Find method is wrapped in this function:
Function Range_ƒFind_Action(sWhat As String, rTrg As Range) As Boolean
Where:
sWhat: contains the string to search for
rTrg: is the range to be searched
The function returns True if any match is found, otherwise it returns False
Additionally, every time the function finds a match it passes the resulting range to the procedure Range_Find_Action to execute the required action, (i.e. "enter a dash in the cell below it"). The "required action" is in a separated procedure to allow for customization and flexibility.
This is how the function is called:
This test is searching for "total" to show the effect of the MatchCase:=False. The match can be made case sensitive by changing it to MatchCase:=True
Sub Range_Find_Action_TEST()
Dim sWhat As String, rTrg As Range
Dim sMsgbdy As String
sWhat = "total" 'String to search for (update as required)
Rem Set rTrg = ThisWorkbook.Worksheets("Sht(0)").UsedRange 'Range to Search (use this to search all used cells)
Set rTrg = ThisWorkbook.Worksheets("Sht(0)").Rows(6) 'Range to Search (update as required)
sMsgbdy = IIf(Range_ƒFind_Action(sWhat, rTrg), _
"Cells found were updated successfully", _
"No cells were found.")
MsgBox sMsgbdy, vbInformation, "Range_ƒFind_Action"
End Sub
This is the Find function
Function Range_ƒFind_Action(sWhat As String, rTrg As Range) As Boolean
Dim rCll As Range, s1st As String
With rTrg
Rem Set First Cell Found
Set rCll = .Find(What:=sWhat, After:=.Cells(1), _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Rem Validate First Cell
If rCll Is Nothing Then Exit Function
s1st = rCll.Address
Rem Perform Action
Call Range_Find_Action(rCll)
Do
Rem Find Other Cells
Set rCll = .FindNext(After:=rCll)
Rem Validate Cell vs 1st Cell
If rCll.Address <> s1st Then Call Range_Find_Action(rCll)
Loop Until rCll.Address = s1st
End With
Rem Set Results
Range_ƒFind_Action = True
End Function
This is the Action procedure
Sub Range_Find_Action(rCll)
rCll.Offset(1).Value2 = Chr(167) 'Update as required - Using `§` instead of "-" for visibilty purposes
End Sub
I am working through my first VBA book and would appreciate if someone would point me in the right direction. How would I transfer a range of rows into a single cell with carriage returns? I would then like to repeat this action for all ranges in the column.
I think I need to:
find the first cell with a value in the column
verify that the next row is not empty
find the last cell in the range
perform "the operation" on the range
Following up on my comments. here is a very simple way to achieve what you want.
Option Explicit
'~~> You can use any delimiter that you want
Const Delim = vbNewLine
Sub Sample()
Dim rngInput As Range, rngOutput As Range
Application.ScreenUpdating = False
Set rngInput = Range("A1:A5") '<~~ Input Range
Set rngOutput = Range("B1") '<~~ Output Range
Concatenate rngInput, rngOutput
Application.ScreenUpdating = True
End Sub
Sub Concatenate(rng1 As Range, rng2 As Range)
Dim cl As Range
Dim strOutPut As String
For Each cl In rng1
If strOutPut = "" Then
strOutPut = cl.Value
Else
strOutPut = strOutPut & Delim & cl.Value
End If
Next
rng2.Value = strOutPut
End Sub
Within the context of a worksheet-level code, the following will work. Column 2 is hard-coded, so you might want to pass in a value or otherwise modify it to fit your needs.
Dim rng As Range
Set rng = Me.Columns(2)
Dim row As Integer
row = 1
' Find first row with non-empty cell; bail out if first 100 rows empty
If IsEmpty(Me.Cells(1, 2)) Then
Do
row = row + 1
Loop Until IsEmpty(Me.Cells(row, 2)) = False Or row = 101
End If
If row = 101 Then Exit Sub
' We'll need to know the top row of the range later, so hold the value
Dim firstRow As Integer
firstRow = row
' Combine the text from each subsequent row until an empty cell is encountered
Dim result As String
Do
If result <> "" Then result = result & vbNewLine
result = result & Me.Cells(row, 2).Text
row = row + 1
Loop Until IsEmpty(Me.Cells(row, 2))
' Clear the content of the range
Set rng = Me.Range(Me.Cells(firstRow, 2), Me.Cells(row, 2))
rng.Clear
' Set the text in the first cell
Me.Cells(firstRow, 2).Value2 = result