I have a column with 7000+ names. I want to make each name's length not excess to 5. Here is what I have tried which doesn't work
Sub del()
Dim myCell
Set myCell = ActiveCell
Dim count As Integer
count = Len(ActiveCell)
While count > 5
myCell = Left(myCell, Len(myCell) - 1)
myCell.Offset(1, 0).Select
Set myCell = ActiveCell
Wend
End Sub
No need for VBA. You can use a formula, =Left(A1,5), to get the first 5 characters of the cell. Simply autofill the formula down.
If you still want VBA then also you do not need to loop. See this example. For explanation see Convert an entire range to uppercase without looping through all the cells
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim rng As Range
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & lRow)
rng = Evaluate("index(left(" & rng.Address(External:=True) & ",5),)")
End With
End Sub
In the above code I am assuming that the data is in column A in Sheet1. Change as applicable.
In Action
Related
I would like to set up the different formula for negative and positive values.
My code below suppose to be valid, but only the formula for negative values work.
Dim wks As Worksheet
Dim sunString As String
Dim rng3 As Range
sunString = "-"
Set wks = ThisWorkbook.ActiveSheet
Set rng3 = wks.Range("F2:F" & lRow)
With rng3
If InStr(sunString, "-") > 0 Then
Range("W2:W" & lRow).Formula = "=R2-U2-V2"
Else
Range("W2:W" & lRow).Formula = "=R2+U2+V2"
End If
The second formula (else statement) doesn't work at all.
What is wrong here?
Why not use a single formula that includes the condition and get rid of the unneeded looping?
Sub LoopRange()
Dim wks As Worksheet
Dim lRow As Long
Dim rng As Range
Set wks = ThisWorkbook.ActiveSheet
lRow = wks.Cells(wks.Rows.Count, "F").End(xlUp).Row
Set rng = wks.Range("W2:W" & lRow)
rng.Formula = "=IF(F2<0,R2-U2-V2 ,R2+U2+V2)"
End Sub
If the data in column F is not numeric you could use this formula to check for -.
rng.Formula = "=IF(LEFT(F2)=""-"",R2-U2-V2 ,R2+U2+V2)"
I'm trying to clear the data before the keyword TRUE including blank cells in between, and also I don't want to hardcode the range because the range will keep on change. can anyone please help me with this.
A
1
2
3
4
5
3
4
53
53
TRUE
I hope it is what you need.
Option Explicit
Sub clr()
Dim ws As Worksheet
Set ws = Sheet1 'The sheet where the data are
Dim rng As Range
Set rng = ws.Range("A:A") 'Range where the data are
Dim rngFind As Range
Set rngFind = rng.Find("TRUE") 'Find TRUE
Dim rngClear As Range
Set rngClear = Range("A1", rngFind.Offset(-1)) 'Set the range to clear
rngClear.Clear
End Sub
I assume that cell containing value "True" as the last value in the column "A". If that is the case below code will clear the content of all the cells above to it.
Sub ClearCells()
Dim lastRow As Integer
Dim actSheet As Worksheet
Set actSheet = ThisWorkbook.ActiveSheet
With actSheet
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & lastRow - 1).Clear
End With
End Sub
Thanks,
KV Ramana
Update: I realized that I can't use union on multiple sheets.
What's the best choice that I have then?
I simply want to combine all sheets in the workbook into the first worksheet.
After I went through the existing questions, I've tried adding Set rng = nothing to clear my range, but it didn't help.
Sub Combine()
Dim J As Long
Dim Combine As Range
Dim rng As Range
'I want to start from the second sheet and go through all of them
For J = 2 To Sheets.Count
With Sheets(J)
Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With
For Each Cell In rng
If Combine Is Nothing Then
Set Combine = Cell.EntireRow
Else
Set Combine = Union(Combine, Cell.EntireRow)
End If
Next Cell
Set rng = Nothing
Next J
'Paste the whole union into the 1st sheet
Combine.Copy Destination:=Sheets(1).Range("A1")
End Sub
All this code gets me an error Method 'Union' of object '_Global failed
Update 2
Sub Combine2()
Dim rowcount As Long
For Each Sheet In Sheets
If Sheet.Index <> 1 Then
rowcount = Sheet.UsedRange.Rows.Count
Sheet.UsedRange.Copy Destination:=Sheets(1).Cells(Lastrow + 1, 1)
Lastrow = Lastrow + rowcount
End If
Next Sheet
End Sub
Really simple code, worked perfectly, thanks to #luuklag for leading me on this.
Indeed .Union method doesn't work across worksheets.
Instead, you could try looping through all your worksheets, copying the corresponding range and pasting it to the destination worksheet.
Something like the following would achieve this:
Sub test()
Dim destinationSheet As Worksheet
Dim sht As Worksheet
Dim destinationRng As Range
Dim rng As Range
Set destinationSheet = ThisWorkbook.Worksheets("Name of your worksheet")
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> destinationSheet.Name Then
With sht
Set rng = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp))
rng.Copy
End With
With destinationSheet
Set destinationRng = .Range("A" & .Rows.Count).End(xlUp)
If destinationRng.Address = .Range("A1").Address Then
destinationRng.PasteSpecial xlPasteValues
Else
destinationRng.Offset(1, 0).PasteSpecial xlPasteValues
End If
End With
End If
Next sht
End Sub
The code above pastes the ranges one by one, in the same column. It can be easily modified to paste the ranges in different columns, one next to the other.
I am still new to coding so i apologise if i dont understand everything.
I need to check each cell of D3:D5000 if they start with GUF. Then remove the GUF from it. Else dont do anything.
This is what ive been trying to use but im getting an error Do ohne Loop:
Sub RemoveGUFfromcellsstartingwithGUF()
Range("D3").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveCell = "end"
Range("B1").Select
Do Until ActiveCell = "end"
If ActiveCell = "GUF*" Then
ActiveCell.Value = Mid(Cell, 4, 999999)
End If
ActiveCell.Offset(1, 0).Select
End Sub
Thanks for any help/suggestions
Firstly, when you are looping through cells, it's best to use For each cell in cells, no need to change selection then.
Firstly, set a range in which you want it to run.
Sub RemoveGUFfromcellsstartingwithGUF()
dim first_cell as Range
dim last_cell as Range
dim rng as Range
set first_cell = ActiveSheet.Range("D1") 'first cell of your range
set last_cell = ActiveSheet.Range("D5000") 'last cell of your range
set rng = Range(first_cell, last_cell) 'range from first_cell to last_cell
For Each cell in rng.cells 'looping through cells of the range
'What you do here will be done to every cell.
if left(cell.value, 3) = "GUF" then cell.value = Mid(cell.value,4)
Next cell
End Sub
I hope this helps.
Is this what you are trying?
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = Sheet1 '<~~ Change this to the relevant sheet
With ws
'~~> Find last row in Col D
lRow = .Range("D" & .Rows.Count).End(xlUp).Row
'~~> Loop through cell in Col D
For i = 3 To lRow
If .Range("D" & i).Value Like "GUF*" Then
.Range("D" & i).Value = Mid(.Range("D" & i).Value, 4)
End If
Next i
End With
End Sub
I have a problem. I need to write the macro which select the values in column E.
Values of selected items should be between values in cell T2 and U2.
After selection, macro should draw the chart.
I tried 3 ways:
First Approach:
Sub wykres1()
Dim rng As Range
Dim cell As Range
Set rng = Range("E1", Range("E65536").End(xlUp))
For Each cell In rng
If cell.Value > "T2" and cell.value < "U2" Then Cell.Select
With Selection
ActiveSheet.Shapes.AddChart2
End With
Next cell
End Sub
Wykres1 Doesn't work, because the line with if is highlighted on red.
Second Approach:
Sub wykres2()
Dim rng As Range
Dim cell As Range
Set rng = Range("E1", Range("E65536").End(xlUp))
For Each cell In rng
If cell.Value > ActiveSheet.Cell(2,20).Value and cell.value < ActiveSheet.Cell(2,21).Value Then Cell.Select
With Selection
ActiveSheet.Shapes.AddChart2
End With
Next cell
End Sub
Wykres2 Doesn't work, because the line with if is highlighted on red.
Third Approach:
Sub wykres3()
Dim rng As Range
Dim cell As Range
Set rng = Range("E1", Range("E65536").End(xlUp))
For Each cell In rng
If cell.value > -35 And cell.value < -32 Then cell.Select
With Selection
ActiveSheet.Shapes.AddChart2
End With
Next cell
End Sub
Wykres3 freeze after run. When I remove the part with draw chart, the
macro select one cell not the range with selected values. And here I
put the values in macro (-35) (-32) - but I'm interested in possibility
to put values from cells (T2) (U2).
As I mentioned - I need to create macro which select the cells in column E with values between values in cells T2 and U2. After selection macro must draw the chart.
Thank You for Your help.
Try this (Untested). avoid the use of .Select. Work with objects. You may want to see How to avoid using Select in Excel VBA
Sub wykres1()
Dim rng As Range, cell As Range
Dim lRow As Long, i As Long
Dim ws As Worksheet
'~~> Change as applicable
Set ws = Sheet1
With ws
'~~> Find last row in Col E
lRow = .Range("E" & .Rows.Count).End(xlUp).Row
'~~> Loop though the range
For i = 1 To lRow
If .Range("E" & i).Value > .Range("T2").Value And _
.Range("E" & i).Value < .Range("U2").Value Then
With .Range("E" & i)
'
'~~> Do Something
'
End With
End If
Next i
End With
End Sub
As I mentioned - I need to create macro which select the cells in column E with values between values in cells T2 and U2. After selection macro must draw the chart.
You can store each range found above in one range object and then use that. See this example
Sub wykres1()
Dim rng As Range, cell As Range
Dim lRow As Long, i As Long
Dim ws As Worksheet
Dim Obj As ChartObject
'~~> Change as applicable
Set ws = Sheet1
With ws
'~~> Find last row
lRow = .Range("E" & .Rows.Count).End(xlUp).Row
'~~> Liip though the range
For i = 1 To lRow
If .Range("E" & i).Value > .Range("T2").Value And _
.Range("E" & i).Value < .Range("U2").Value Then
'~~> Store the cell in a range object
If rng Is Nothing Then
Set rng = .Range("E" & i)
Else
Set rng = Union(rng, .Range("E" & i))
End If
End If
Next i
'~~> Once you have the range, create a chart and assign range
If Not rng Is Nothing Then
With .ChartObjects.Add(Left:=100, Width:=375, Top:=75, Height:=225)
.Chart.SetSourceData Source:=rng
.Chart.ChartType = xlColumnClustered
End With
End If
End With
End Sub