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
Related
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
I have two columns of numbers, together they will be unique (composite key). I would like to create an unique ID number (third column) similar to how MS Access would use a primary key. I would like to do this in VBA but I am stuck on how to do it.
My VBA in excel isn't very good so hopefully you can see what I've started to attempt. it may be completely wrong... I don't know?
I don't know how to make the next concatenation and I am unsure about how to go down to the next row correctly.
Sub test2()
Dim var As Integer
Dim concat As String
concat = Range("E2").Value & Range("F2").Value
var = 1
'make d2 activecell
Range("D2").Select
Do Until concat = ""
'if the concat is the same as the row before we give it the same number
If concat = concat Then
var = var
Else
var = var + 1
End If
ActiveCell.Value = var
ActiveCell.Offset(0, 1).Select
'make the new concatination of the next row?
Loop
End Sub
any help is appreciated, thanks.
Give the code below a try, I've added a loop which executes for each cell in the E Column. It checks if the concat value is the same as the concat value in the row above and then writes the id to the D cell.
Sub Test2()
Dim Part1 As Range
Dim strConcat As String
Dim i As Long
i = 1
With ThisWorkbook.Worksheets("NAME OF YOUR SHEET")
For Each Part1 In .Range(.Cells(2, 5), .Cells(2, 5).End(xlDown))
strConcat = Part1 & Part1.Offset(0, 1)
If strConcat = Part1.Offset(-1, 0) & Part1.Offset(-1, 1) Then
Part1.Offset(0, -1).Value = i
Else
i = i + 1
Part1.Offset(0, -1).Value = i
End If
Next Part1
End With
End Sub
Something like this should work, this will return a Unique GUID (Globally Unique Identifier):
Option Explicit
Sub Test()
Range("F2").Select
Do Until IsEmpty(ActiveCell)
If (ActiveCell.Value <> "") Then
ActiveCell.Offset(0, 1).Value = CreateGUID
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Public Function CreateGUID() As String
CreateGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function
If you walk down column D and examine the concatenated values from column E and F with the previous row, you should be able to accomplish your 'primary key'.
Sub priKey()
Dim dcell As Range
With Worksheets("Sheet12")
For Each dcell In .Range(.Cells(2, 4), .Cells(Rows.Count, 5).End(xlUp).Offset(0, -1))
If LCase(Join(Array(dcell.Offset(0, 1).Value2, dcell.Offset(0, 2).Value2), ChrW(8203))) = _
LCase(Join(Array(dcell.Offset(-1, 1).Value2, dcell.Offset(-1, 2).Value2), ChrW(8203))) Then
dcell = dcell.Offset(-1, 0)
Else
dcell = Application.Max(.Range(.Cells(1, 4), dcell.Offset(-1, 0))) + 1
End If
Next dcell
End With
End Sub
You could use collections as well.
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range, LstRw As Long
Dim Cell As Range
Dim vNum As Variant, c As Range, y
LstRw = Cells(Rows.Count, "E").End(xlUp).Row
Set Rng = Range("E2:E" & LstRw)
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value & Cell.Offset(, 1), CStr(Cell.Value & Cell.Offset(, 1))
Next Cell
On Error GoTo 0
y = 1
For Each vNum In cUnique
For Each c In Rng.Cells
If c & c.Offset(, 1) = vNum Then
c.Offset(, -1) = y
End If
Next c
y = y + 1
Next vNum
End Sub
Hi I have a excel sheet with different action types such as dividends, annual general meetings and so on..
Is there a way to write a vba macro that takes all the action types and puts them into separate sheet within the workbook ? Also the header such as date time should be included in all of the sheets. I am kind of struggling with this atm as I am new to VBA: I have a screen shot of the excel sheet..
Again thanks in advance.
I have the code which sorts for dividends however I am struggling to get the actions into a list and then go through the list and create new sheets.
Sub SortActions()
Dim i&, k&, s$, v, r As Range, ws As Worksheet
Set r = [index(a:a,match("###start",a:a,),):index(a:a,match("###end",a:a,),)].Offset(, 6)
k = r.Row - 1
v = r
For i = 1 To UBound(v)
If LCase$(v(i, 1)) = "dividend" Then
s = s & ", " & i + k & ":" & i + k
End If
Next
s = Mid$(s, 3)
If Len(s) Then
Set ws = ActiveSheet
With Sheets.Add(, ws)
ws.Range(s).Copy .[a1]
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("20140701_corporate_action_servi").Select
Rows("2:2").Select
Selection.Copy2
Range("C32").Select
Sheets("Sheet11").Select
ActiveSheet.Paste
End With
End If
End Sub
This should do it:
Public Sub CopyActionTypes()
Dim i&, k&, key, v, r As Range, ws As Worksheet, d As Object
On Error Resume Next
Set r = [index(a:a,match("###start",a:a,),):index(a:a,match("###end",a:a,),)].Offset(, 6)
If Err = 0 Then
On Error GoTo 0
k = r.Row + 1
v = r
Set d = CreateObject("scripting.dictionary")
d.CompareMode = 1
For i = 1 To UBound(v)
key = v(i, 1)
If Len(key) Then
If Not d.Exists(key) Then d.Add key, k & ":" & k
d(key) = d(key) & Replace(",.:.", ".", i)
End If
Next
Set ws = ActiveSheet
For Each key In d.Keys
If LCase$(key) <> "action_type" Then
With Sheets.Add(, ws.Parent.Sheets(ws.Parent.Sheets.Count))
.Name = key
GetRangeUnion(d(key), ws).Copy .[a1]
End With
End If
Next
End If
End Sub
Private Function GetRangeUnion(s As String, ws As Worksheet) As Range
Dim i&, v, r As Range
v = Split(s, ",")
Set r = ws.Range(v(0))
For i = 1 To UBound(v)
Set r = Union(r, ws.Range(v(i)))
Next
Set GetRangeUnion = r
End Function
As an aside, try to not select anything from code during your macros. This is a best practice and one of many ways to optimize code.
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
I need to do some calculations for each cell in two aligned columns in EXCEL 2010 by VBA on Win7.
Write the result in a cell of another column.
My code:
Set result_rng = Range("H2:H10")
Set aRng = Range("C2:C10")
Set bRng = Range("F2:F10")
For Each aCell, bCell, cCell In aRng, bRng, result_rng // **error here**
cEll.Value = Cdl(aCell.Value) - Cdl(b.Cell.Value)
Next aCell
I also need to check wether F column is "NULL", if yes, I will not do calculation and just update a counter.
update new error of caling a sub
find_max rng1:=rng // error !!! ByRef argu mismatch
Sub find_max(ByRef rng1 As Range)
Dim dblM As Double
dblM = -9E+307
Dim maxCellAddress As String
For Each Cell In rng
If IsNumeric(c) Then
If dblMax < CDbl(Cell.Value) And Cell.Value <> "" Then
dblM = CDbl(Cell.Value)
maxCellAddress = (Cell.Address)
End If
End If
Next Cell
End Sub
Any help would be appreciated.
UPDATE 1
Try this one:
Sub test()
Dim rng As Range, c As Range
Set rng = Range("C2:C10")
For Each c In rng
If c.Offset(0, 3).Value <> "NULL" Then
c.Offset(0, 5).Value = c.Value - c.Offset(0, 3).Value
End If
Next c
End Sub
where c.Offset(0, 3) means offset to the right on 3 columns, i.e. if c refers to cell in column C, then c.Offset(0, 3) gives you corresponding value from column F and c.Offset(0, 5) gives you corresponding value from column H.
If it seems too tricky, you can use this one instead:
Range("H" & c.Row).Value = c.Value - Range("F" & c.Row).Value
UPDATE 2
Sub test()
Dim result_rng As Range, c As Range
Dim dblM As Double
Dim maxCellAddress As String
Set result_rng = Range("H2:H10")
dblM = -9E+307
For Each c In result_rng
If IsNumeric(c) Then
If dblM < CDbl(c.Value) And c.Value <> "" Then
dblM = CDbl(c.Value)
maxCellAddress = c.Address
End If
End If
Next c
End Sub