I currently have some code that finds cells not in the first column and moves them over. I'm facing a problem with cells that start with "=". Can you guys think of any work-arounds to solve this problem. Thanks in Advance.
Sub Move()
Dim cel As Range, rng As Range
Dim wk As Worksheet
Set wk = ActiveWorkbook.ActiveSheet
Set rng = wk.UsedRange
For Each cel In rng
If cel.Value <> "" And cel.Column <> 1 Then
wk.Cells(cel.Row, 1) = cel.Value
cel.Value = ""
End If
Next cel
End Sub
Either every time in your For each loop
If Cstr(cel.Value) <> "" And ... 'you need to do that for every cel.Value occurencies
Or declare a variable at the beginning
Dim StringInCell as String
For Each cel In rng
StringInCell=Cstr(cel.Value)
If StringInCell...
You may try .Text property as well (though I haven't had luck using that ever, I rather to use CStr).
This may work as well if the parsed data is throwing an error exception or something:
...
wk.Cells(cel.Row, 1).NumberFormat = "#"
wk.Cells(cel.Row, 1) = Cstr(cel.Value) 'related to the option chosen from above
Try this
Sub Move()
Dim cel As Range, rng As Range
Dim wk As Worksheet
Set wk = ActiveWorkbook.ActiveSheet
Set rng = wk.UsedRange
For Each cel In rng
If cel.HasFormula Then
wk.Cells(cel.Row, 1).Formula = cel.Formula
cel.ClearContents
Else
If cel.Value <> "" And cel.Column <> 1 Then
With wk.Cells(cel.Row, 1)
.NumberFormat = "#" '<<edit: added formatting
.Value = cel.Value
End with
cel.Value = ""
End If
End If
Next cel
End Sub
If you have cells that begin with =, but are not to be treated as formulas, but rather as Text, then using Sgdva's alternative suggestion:
Sub Move()
Dim cel As Range, rng As Range
Dim wk As Worksheet
Set wk = ActiveWorkbook.ActiveSheet
Set rng = wk.UsedRange
For Each cel In rng
If cel.Text <> "" And cel.Column <> 1 Then
wk.Cells(cel.Row, 1) = cel.Text
cel.Value = ""
End If
Next cel
End Sub
EDIT#1:
This version should "de-formularise" a cell before moving it to column 1:
Sub Move2()
Dim cel As Range, rng As Range
Dim wk As Worksheet, s As String
Set wk = ActiveWorkbook.ActiveSheet
Set rng = wk.UsedRange
For Each cel In rng
s = cel.Text
If s <> "" And cel.Column <> 1 Then
wk.Cells(cel.Row, 1).Value = s
cel.Value = ""
End If
Next cel
End Sub
Related
So I need to select the same range in all worksheets except "Sheet1". The range is dinamic based on the value "s1" on the column A. So I want to select what is in column B for the value s1, make it bold, then to count the s1 values in column C.
This is what I have so far
Sub test()
Dim ws As Worksheet
Dim lastrow As Long
Dim xRg As Range, yRg As Range, zRg As Range
Dim cell As Range
Dim C1 As Range
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet1" Then
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For Each xRg In Range("A1:A" & lastrow)
If xRg.Text = "s1" Then
If yRg Is Nothing Then
Set yRg = Range("B" & xRg.Row).Resize(, 1)
k = 1
For Each cell In yRg
yRg.Cells(k, 2) = k
yRg.Cells.Select
k = k + 1
Next cell
Else
Set yRg = Union(yRg, Range("B" & xRg.Row).Resize(, 1))
If Not yRg Is Nothing Then yRg.Select
For Each C1 In yRg
C1.EntireRow.Font.Bold = True
Next C1
End Sub
Try this code:
Option Explicit
Sub test()
Dim ws As Worksheet
Dim xRg As Range, yRg As Range
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet1" Then
ws.Cells.Font.Bold = False ' clear bold formatting for debugging purposes
Set yRg = Nothing
For Each xRg In ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
If xRg.Text = "s1" Then
If yRg Is Nothing Then
Set yRg = xRg.Offset(0, 1)
Else
Set yRg = Union(yRg, xRg.Offset(0, 1))
End If
xRg.Offset(0, 2) = yRg.Cells.Count 'set entry number
End If
Next xRg
If Not yRg Is Nothing Then yRg.Font.Bold = True
End If
Next ws
Application.ScreenUpdating = True
End Sub
Before
After
A selection or a range does not extend across multiple sheets; there is a selection per sheet. So you need to work within each sheet.
You had a lot of unclosed loops and conditions. This is my best guess at what you were trying to do:
Sub test()
Dim ws As Worksheet
Dim lastrow As Long
Dim xRg As Range, yRg As Range
Dim cell As Range
Dim s1count As Long
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet1" Then
Set yRg = Nothing
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For Each xRg In Range("A1:A" & lastrow)
If xRg.Text = "s1" Then
If yRg Is Nothing Then
Set yRg = xRg.Offset(0, 1)
Else
Set yRg = Union(yRg, xRg.Offset(0, 1))
End If
End If
Next xRg
If Not yRg Is Nothing Then
s1count = 0
For Each cell In yRg
cell.EntireRow.Font.Bold = True
s1count = s1count + 1
cell.Offset(0, 1) = s1count
Next cell
End If
End If
Next ws
End Sub
I have an excel workbook where I want to find the cell that contains "A0_" & A where A is the value from another worksheet. The end goal is to copy the column with "A0_" & A to another sheet titled. Here is my code so far.
Sub Copy_A()
Dim A As String
Dim iRng As Range
Dim cel As Range
Dim dataws As Worksheet
Dim Rng1, Rng2, Rng3, NewRng As Range
Set dataws = Worksheets("Data Importation Sheet")
Set iRng = dataws.Range(dataws.Cells(1, 1), dataws.Cells(1, dataws.Cells(1, Columns.Count).End(xlToLeft).Column))
A = Worksheets("Information Sheet").Range("E12").Value
For Each cel In iRng
If cel.Value = "A0_" & A Then
Set Rng1 = cel.EntireColumn.Find(What:="", LookIn:=xlValues, lookat:=xlPart)
Debug.Print Rng1.FormulaR1C1
Set Rng2 = dataws.Cells(Rng1.Row - 1, Rng1.Column + 1)
Debug.Print Rng2.FormulaR1C1
Set Rng3 = Cells(cel.Row + 1, cel.Column)
Debug.Print Rng3.FormulaR1C1
End If
Next cel
With dataws
Set NewRng = .Range(Rng3.Address & ":" & Rng1.Address)
Debug.Print NewRng.Address
NewRng.Select
End With
End Sub
For some reason the code does not recognize "A0_" & A when it reaches that cell. The code goes through each column but does not execute setting the ranges. Any tips/help would be greatly appreciated! Here is a picture of my workbook to give you a better idea of what is happening
I have the below code that copies a range from one sheet and pastes it in a differ sheet and does a calculation (ignores the colored values).
What I want to do is, I want to add additional cells into this code to perform the same function but for a slightly different formula...
The formula I ant to use is given below and the destiantion cells are AH 101 and AH102.
"=PERCENTILE.INC(" & Rng.Address(, , , True) & ",90%)*24"
"=PERCENTILE.INC(" & Rng.Address(, , , True) & ",50%)*24"
This is my entire code:
Sub TPNoRed()
Dim cel As Range
Dim Rng As Range
Dim arr As Variant
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Sheets("TP").Range("A3:D30")
If cel.Font.Color = 0 Then
If Rng Is Nothing Then
Set Rng = cel
Else
Set Rng = Union(cel, Rng)
End If
End If
Next cel
ReDim arr(Rng.count - 1)
If Not Rng Is Nothing Then
For Each cel In Rng
arr(i) = cel
i = i + 1
Next cel
Sheets("TP").Range("AH1").Resize(UBound(arr) + 1).Value = Application.Transpose(arr)
Set Rng = Sheets("TP").Range("AH1:AH" & Sheets("TP").Cells(Rows.count, "AH").End(xlUp).Row)
Sheets("WBR45").Range("AH103").Formula = "=PERCENTILE.INC(" & Rng.Address(, , , True) & ",99%)*24"
Sheets("WBR45").Range("AH103").Value = Sheets("WBR45").Range("AH103").Value
Sheets("TP").Columns("AH:AH").ClearContents
Application.ScreenUpdating = True
End Sub
I'm more than new at this, and I'm having trouble sorting out For...Next loops.
I want to track to two text variables in two columns, so that when both variables are found in a row text is added to that row in a different column.
This is what I have so far:
Sub AB()
Dim Rng1 As Range
Dim Rng2 As Range
Set Rng1 = Range("B1:B100")
Set Rng2 = Range("A1:A100")
For Each cel In Rng1
If InStr(1, cel.Value, "A") > 0 Then
For Each cel In Rng2
If InStr(1, cel.Value, "B") > 0 Then
cel.Offset(0, 5).Value = "AB"
End If
Next
End If
Next cel
End Sub
You might even be able to just do this?
Sub AB()
With ActiveSheet
For I = 1 To 100
If InStr(1, .Cells(I, 2), "A") > 0 And InStr(1, .Cells(I, 1), "B") > 0 Then
.Cells(I, 6).Value = "AB" 'i think offset 5 is column F?
End If
Next
End With
End Sub
Appreciate you have an answer now, but here's a different method using Find. Always good to know several ways to do something.
Sub AB()
Dim rng As Range
Dim itemaddress As String
With Columns(1)
Set rng = .Find("A", searchorder:=xlByRows, lookat:=xlWhole)
If Not rng Is Nothing Then
itemaddress = rng.Address
Do
If rng.Offset(0, 1) = "B" Then
rng.Offset(0, 2).Value = "AB"
End If
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And itemaddress <> rng.Address
End If
End With
End Sub
You're using `cel' to step through each loop - the inner loop will get confused.
Along the vein of #findwindow answer (appeared as I was typing this). Loop just once and when a match is found check the cell next to it.
Sub AB()
Dim Rng1 As Range
Dim Rng2 As Range
Dim cel1 As Range
'Be specific about which sheet your ranges are on.
With ThisWorkbook.Worksheets("Sheet1")
Set Rng1 = .Range("B1:B100")
Set Rng2 = .Range("A1:A100")
End With
For Each cel1 In Rng1
'Check each value in column B.
If InStr(1, cel1.Value, "A") > 0 Then
'If a match is found, check the value next to it.
If InStr(1, cel1.Offset(, -1), "B") > 0 Then
cel1.Offset(, 4).Value = "AB"
End If
End If
Next cel1
End Sub
I want to select every column that has the word "TEST" in the 5th row range, and then select the cells below down to a certain amount.
I have can find and select the range I want, I just cant have all my selections when I finish, and I want them so I can do some conditional formatting.
Public Sub Macro1()
Dim n As Integer
n = 5
For Each c In Worksheets("Sheet1").Range("E5:UM5").Cells
If InStr(1, "TEST", "TEST") Then
Range(Cells(6, n), Cells(48, n)).Select
n = n + 1
End If
Next
End Sub
Do you think a array would help me to keep the data to then select after?
The code below is modified from user ooo answer here .
Is there a reason you need to select cells? In vba you can do most things without actually selecting cells which makes it quicker and less prone to errors.
If you do need to select the cells I would build up the range and then select it all at once at the end.
Gordon
Sub test()
Dim rng1 As Range
Dim rng2 As Range
Dim newRng As Range
With Sheet1
Set rng1 = .Range("A1:A3")
Set rng2 = .Range("C3:C5")
Set newRng = Union(rng1, rng2)
set rng2 = .range("E5:E7")
set newRng = Union(newRng,rng2)
newrng.select
End With
End Sub
Applied to your code
Public Sub Macro1()
Dim n As Integer
dim rng as range
n = 5
For Each c In Worksheets("Sheet1").Range("E5:UM5").Cells
If InStr(1, "TEST", "TEST") Then
If rng Is Nothing Then
Set rng = Range(Cells(6, n), Cells(48, n))
else
set rng = union(rng, range(cells(6,n),cells(48,n)))
end if
n = n + 1
End If
Next
rng.select
End Sub
Public Sub Macro1()
Dim n As Integer, rng as Range, sht as WorkSheet
Set sht = Worksheets("Sheet1")
For Each c In sht.Range("E5:UM5").Cells
If c.value Like "*TEST*" Then
If rng is nothing then
Set rng = c.offset(1,0).Resize(43,1)
else
Set rng = Application.union(rng, c.offset(1,0).Resize(43,1))
end if
End If
Next
rng.select
End Sub
Public Sub Macro1()
Dim c As Range, rng As Range, ws As Worksheet
Set ws = Worksheets("Sheet1")
For Each c In ws.Range("E5:UM5").Cells
If InStr(c, "TEST") Then
If rng Is Nothing Then
Set rng = c
Else
Set rng = Application.Union(rng, c)
End If
End If
Next
If Not rng Is Nothing Then
rng.Select
Debug.Print rng.Address
Else
Debug.Print "Not found"
End If
End Sub