I want to create a macro for the following:
For each row, if there are cell values in range C3:ACP3 that are >= value of ACU3, I want to replace that cell value with blank. I want to do this for every row, and each time the macro should reference the value in the ACU column for that row.
Try this:
Sub makeBlank()
Dim r As Range
Set r = Excel.ThisWorkbook.Sheets("Sheet1").Range("C3:ACP3")
Dim v As Double
v = Excel.ThisWorkbook.Sheets("Sheet1").Range("ACU3").Value
Dim c
For Each c In r
If c.Value >= v Then
c.Value = ""
End If
Next c
End Sub
EDIT
I suspect this will be quicker using arrays:
Sub makeBlank2()
Dim v
v = Excel.ThisWorkbook.Sheets("Sheet1").Range("ACU3").Value
Dim Arr() As Variant
Arr = Sheet1.Range("C3:ACP3")
Dim R, C As Long
For R = 1 To UBound(Arr, 1)
For C = 1 To UBound(Arr, 2)
If Arr(R, C) > v Then
Arr(R, C) = ""
End If
Next C
Next R
Sheet1.Range("C3:ACP3") = Arr
End Sub
Try this:
Sub FindDelete()
Dim ACU_Val As Double
Dim cl As Range
Dim rw As Long
For rw = 1 To Rows.Count
If Range("ACU" & rw).Value = "" Then Exit For
ACU_Val = Range("ACU" & rw).Value
For Each cl In Range("C" & rw & ":ACP" & rw)
If cl.Value >= ACU_Val Then cl.Value = ""
Next cl
Next
End Sub
you need to iterate over your desired range of cells and for each cell which contents are above the threshold value in the ACU column of the same row just clear its contents.
For Each c In Range("C3:ACP3")
If c.Value >= Cells(c.Row, "ACU") Then
c.clearContents
End If
Next c
Simple :
Dim myCell As Range
numberOfRows = 1000
For i = 0 To numberOfRows
Dim myRow As Range
Set myRow = [C3:ACP3].Offset(i, 0)
bound = Intersect([acu3].EntireColumn, myRow.EntireRow)
For Each myCell In myRow
If myCell >= bound Then myCell = ""
Next
Next
Related
Here is my current output that my VBscript is generating.
ID DESCRIPTION 1 RECURSIVE_ANALYSIS
CM-1 xxxxxxxxxxxx Issue A
Sub issue a
Sub issue b
Sub issue c
CM-2 yyyyyyyyyyy Issue B
Sub issue a
Sub issue b
This is following VBA code which i have designed for getting the output
Sub CellSplitter1()
Dim Temp As Variant
Dim CText As String
Dim J As Integer
Dim K As Integer
Dim L As Integer
Dim iColumn As Integer
Dim lNumCols As Long
Dim lNumRows As Long
Dim wksNew As Worksheet
Dim wksSource As Worksheet
Dim iTargetRow As Integer
iColumn = 3
Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add
iTargetRow = 0
With wksSource
lNumCols = .Range("IV1").End(xlToLeft).Column
lNumRows = .Range("A65536").End(xlUp).Row
For J = 1 To lNumRows
CText = .Cells(J, iColumn).Value
Temp = Split(CText, Chr(10))
For K = 0 To UBound(Temp)
iTargetRow = iTargetRow + 1
For L = 1 To lNumCols
If L <> iColumn Then
wksNew.Cells(iTargetRow, L) _
= .Cells(J, L)
Else
wksNew.Cells(iTargetRow, L) _
= Temp(K)
End If
Next L
Next K
Next J
End With
End Sub
Here is my expected output
ID DESCRIPTION 1 RECURSIVE_ANALYSIS Issues
CM-1 xxxxxxxxxxxx Issue A Sub issue a
Sub issue b
Sub issue c
CM-2 yyyyyyyyyyy Issue B Sub issue a
Sub issue b
So, can someone help me to figure out to get the expected output.
Any help will be much appreciated.
Thank you
it seems you didn't show the whole story, so here's a guessing:
after your code place the following
With wksNew' reference 'wksNew' sheet
With .Range(.Cells(1, iColumn), .Cells(iTargetRow, iColumn)) ' reference its 'iColumn' column range from row 1 down to its last not empty one
.Insert 'insert a new column before referenced range. now the currently referenced range is one column right shifted (i.e. its in the 4th column of referenced sheet)
.Offset(, -1).Value = .Value ' copy values from referenced range one column to the left (i.e. in the newly created column)
.Offset(, -1).Replace "Sub issue*", "", lookat:=xlWhole 'clear the newly created range cells containing "Sub issue..." (hence, there remains cells with "Issue .." only)
.Replace "Issue *", "", lookat:=xlWhole 'clear the currently referenced range (i.e the one in 4th column) cells containing "Issue..." (hence, there remains cells with "Sub issue .." only)
End With
.Columns.AutoFit 'adjust your columns width
End With
Using Variant array is more simple.
Sub test()
Dim r As Long, c As Integer
Dim j As Integer
Dim k As Integer
Dim wksNew As Worksheet
Dim wksSource As Worksheet
Dim vDB, vSplit, vR()
Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add
With wksSource
c = .Range("IV1").End(xlToLeft).Column
r = .Range("A65536").End(xlUp).Row
vDB = .Range("a1", .Cells(r, c))
For i = 1 To r
vSplit = Split(vDB(i, c), Chr(10))
For k = 1 To UBound(vSplit)
n = n + 1
ReDim Preserve vR(1 To c + 1, 1 To n)
If k = 1 Then
For j = 1 To c - 1
vR(j, n) = vDB(i, j)
Next j
vR(c, n) = vSplit(k - 1)
vR(c + 1, n) = vSplit(k)
Else
vR(c + 1, n) = vSplit(k)
End If
Next k
Next i
End With
Range("a1").Resize(1, c + 1) = Array("ID", "DESCRIPTION 1", "RECURSIVE_ANALYSIS", "Issues")
Range("a2").Resize(n, c + 1) = WorksheetFunction.Transpose(vR)
End Sub
Here is the sample of my current output which the VBscript code is generating.
[https://i.stack.imgur.com/kMpih.png] [1]:
Here is the sample of my expected output
[[1]: https://i.stack.imgur.com/StBqx.png]
Please let me know your suggestions.
Thank you
I have data like below and want to swap value
My VBA script is ,
Private Sub CommandButton2_Click()
Dim temp As Double
temp = Range("A1").Value
Range("A1").Value = Range("B1").Value
Range("B1").Value = temp
End Sub
It works fine, but If i have multiple data like,
I want to swap value where 1 in C column like,
So How do I modify my vba script to work multiple data swap where 1.
Thanks in Advance.
Let's assume the values are constants. We will make a loop over the stuff in column C:
Sub MultiSwap()
Dim C As Range, r As Range, v As Variant
Set C = Range("C:C").Cells.SpecialCells(xlCellTypeConstants)
For Each r In C
If r.Value = 1 Then
v = r.Offset(0, -2).Value
r.Offset(0, -2).Value = r.Offset(0, -1).Value
r.Offset(0, -1).Value = v
End If
Next r
End Sub
Sub Main()
Dim cl as Range, temp as Range
For each cl in Range("A1:A" & Range("A1").End(xlDown).Row)
If cl.offset(0, 2) = 1 Then
temp = cl
cl = cl.offset(0, 1)
cl.offset(0, 1) = temp
End if
Next cl
End Sub
a proposition
for each c in range("C1:C" & cells(rows.count,1).end(xlup).row)
if c=1 then
temp=c.offset(,-2)
c.offset(,-2)=c.offset(,-1)
c.offset(,-1)=temp
end if
next
my 0.02 cents
Option Explicit
Sub main()
Dim vals As Variant
Dim iRow As Long
With Range("C1", Cells(Rows.count, 1).End(xlUp))
vals = .Value
For iRow = 1 To .Rows.count
If vals(iRow, 3) = 1 Then
.Cells(iRow, 1) = vals(iRow, 2)
.Cells(iRow, 2) = vals(iRow, 1)
End If
Next
End With
End Sub
Length of all cells in a specific columns has to be 6 characters. If not, I have to add 0 in the beginning of each cell until cell length =6. What is the best way to do it?
Dim lastRow As Integer
Dim i As Integer
Dim sh As Worksheet
Dim cont As String
Set sh = ThisWorkbook.Worksheets("Sheet1") 'Your Sheet
With sh
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'Coloumn A
For i = 1 To lastRow
Cells(i, 1).NumberFormat = "#"
Do Until Len(Cells(i, 1)) = 6 'Coloumn A
cont = Cells(i, 1) 'Coloumn A
Cells(i, 1) = "0" & cont 'Coloumn A
Loop
Next i
End With
Does this work for you? You only have to edit the coloumn that you want to check, you could use a TextBox for that.
Here is a sample for column C:
Sub Make6()
Dim r As Range, r1 As Range, r2 As Range, r3 As Range
bry = Array("000000", "00000", "0000", "000", "00", "0", "")
Dim N As Long, v As String, L As Long
Set r1 = Range("C:C")
N = Cells(Rows.Count, "C").End(xlUp).Row
Set r2 = Range("C1:C" & N)
Set r3 = Range("C" & N + 1 & ":C" & Rows.Count)
r1.NumberFormat = "#"
For Each r In r2
v = r.Value
L = Len(v)
If L < 6 Then
r.Value = bry(L) & v
End If
Next r
r3.Value = "000000"
End Sub
It will fix ALL cells in column C.
I have a macro that consolidate the values on another sheet, and based on these values, it´s has to go back on the first sheet and delete.
The sheet it´s like this, if the value on the G2 it´s (Manter a linha), it´s get the number of the row on the F2, and goes to delete the previews of the row.
Else, goes to I2, and do the same.
Thank you for your help and time.
Sheet
I have this so far:
Sub Delete()
Range("G2").Select
Do Until IsEmpty(ActiveCell)
Range("G" & Rows.Count).Select
If Range("G" & 2).Value = ("<<<Manter a linha") Then
Sheets("Controle Estoque Fixo").Select
Rows("2:5").Select
Selection.EntireRow.Delete
End If
Loop
EDIT:
Dim r1 As Range, c As Range
Dim s As String
Dim v As String
Dim k As String
Dim t As String
k = "1"
Set r1 = Range(Cells(2, "H"), Cells(Rows.Count, "H").End(xlUp))
v = Sheets("Analise de Estoque").Cells(2, "G").Value
For Each c In r1
If c.Text = ("<<<Manter a linha") Then
Sheets("Controle Estoque Fixo").Select
t = (v - 1)
Rows(t).Select.Clear
End If
Next
End Sub
Now I can go back and select the value of the cell that contains the row, that I want to keep, so I add a "- 1" to select before that, but I tried to add the begging and won´t work(tried to add T as a string and put = 1)
You need to build your range and delete all the rows at once.
Sub DeleteMatches()
Dim r1 As Range, c As Range
Dim s As String
Set r1 = Range(Cells(2, "G"), Cells(Rows.Count, "G").End(xlUp))
For Each c In r1
If c = "<<<Manter a linha" Then
If Len(s) Then s = s & ","
s = s & "A" & c.Offset(0, -1)
End If
Next
If Len(s) Then
s = Left(s, Len(s) - 1)
Sheets("Controle Estoque Fixo").Range(s).EntireRow.Delete
End If
End Sub
If you only want to clear the rows and not delete then them then you can do it your way.
Sub DeleteMatches2()
Dim r1 As Range, c As Range
Dim t As String
With Sheets("Analise de Estoque")
Set r1 = .Range(.Cells(2, "H"), .Cells(Rows.Count, "H").End(xlUp))
End With
For Each c In r1
If c.Text = "<<<Manter a linha" Then
Sheets("Controle Estoque Fixo").Select
t = c.Offset(0, -1)
Rows(t).ClearContents
End If
Next
End Sub
Sub DeleteMatches3()
Dim r1 As Range, c As Range
Dim i As Long, LastRow As Long
Dim t As String
With Sheets("Analise de Estoque")
LastRow = .Cells(Rows.Count, "H").End(xlUp)
For i = 2 To LastRow
If .Cells(i, "G").Text = "<<<Manter a linha" Then
t = .Cells(i, "F").Text
Sheets("Controle Estoque Fixo").Rows(t).ClearContents
End If
Next
End With
End Sub
Just remember that when you delete rows you have to go from the last row to the first
For i = LastRow To 2 Step - 1
Next
it works good but he doesn't take the last line of the tab
can u please help me to find my errors !
Dim c As Range
Dim MaPlage As Range
For q = 2 To ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
Set MaPlage = Range("A:H, J:R").Rows(q)
For Each c In MaPlage.Cells
If Len(c.Value) = 0 Then c.Interior.Color = vbYellow
If CStr(ActiveSheet.Cells(q, 31).Value) = "Completed - Appointment made / Complété - Nomination faite" _
And WorksheetFunction.CountIf(MaPlage, "") = 0 Then
Select Case UCase(ActiveSheet.Cells(q, 14).Value)
Case "INA_CIN"
ActiveSheet.Cells(q, 42).Value = "XX"
End Select
End If
Next c
Next q
EDIT: updated to show how to highlight empty cells
Dim MaPlage As Range, c As Range
Set MaPlage = Sheet1.Range(Replace("A#:H#,J#:R#", "#", q))
For Each c In MaPlage.Cells '<<EDIT2 to remove extra space
If Len(c.Value) = 0 Then c.Interior.Color = vbRed
Next c
EDIT2:
Sub TT()
Const S As String = "Completed - Appointment made / Complété - Nomination faite"
Dim MaPlage As Range, c As Range, rw As Range
Dim q As Integer, blanks As Long
For q = 2 To ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
Set rw = Sheet1.Rows(q)
Set MaPlage = rw.Range("A1:H1,J1:R1")
blanks = 0
For Each c In MaPlage.Cells
If Len(c.Value) = 0 Then
c.Interior.Color = vbRed
blanks = blanks + 1
End If
Next c
If CStr(rw.Cells(31).Value) = S And blanks = 0 Then
Select Case UCase(rw.Cells(14).Value)
Case "INA_CIN"
rw.Cells(42).Value = "XX"
End Select
End If
Next q
End Sub