Excel Macro Automating Cells and Columns editing - excel

Hi I am trying to automate insertion of columns and moving of data within a certain part of a spreadsheet.
Currently What the Macro is
Sub Macro1()
'
' Macro1 Macro
'
'
Rows("6:9").Select
Selection.Insert Shift:=xlDown
Range("F5").Select
Selection.Cut
Range("E6").Select
ActiveSheet.Paste
Range("G5").Select
Selection.Cut
Range("E7").Select
ActiveSheet.Paste
Range("H5").Select
Selection.Cut
Range("E8").Select
ActiveSheet.Paste
Range("I5").Select
Selection.Cut
Range("E9").Select
ActiveSheet.Paste
Range("A5").Select
Selection.Copy
Range("D6:D9").Select
ActiveSheet.Paste
Range("C6").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "10000"
Range("C7").Select
ActiveCell.FormulaR1C1 = "20000"
Range("C8").Select
ActiveCell.FormulaR1C1 = "30000"
Range("C9").Select
ActiveCell.FormulaR1C1 = "40000"
Range("C10").Select
End Sub
How do i change it so that it will update dynamically when i select a new set of rows again ?


With the following edited macro you can select any number of rows to be inserted and with inputbox
Option Explicit
Sub Macro1()
Dim newRows As Range, newRowsAddress As String, previousRow As Range
Dim ColumnLetter As String, i As Long, j As Long
On Error Resume Next
Set newRows = Application.InputBox("Select rows to insert", "New Rows", , , , , , 8)
If newRows Is Nothing Then Exit Sub
On Error GoTo 0
Set previousRow = newRows.Offset(-1).Resize(1, Columns.Count)
newRowsAddress = newRows.Address
' Rows("6:9").Select
' Selection.Insert Shift:=xlDown
' Range("F5").Select
' Selection.Cut
' Range("E6").Select
' ActiveSheet.Paste
' Range("G5").Select
' Selection.Cut
' Range("E7").Select
' ActiveSheet.Paste
' Range("H5").Select
' Selection.Cut
' Range("E8").Select
' ActiveSheet.Paste
' Range("I5").Select
' Selection.Cut
' Range("E9").Select
' ActiveSheet.Paste
newRows.Insert Shift:=xlDown
Set newRows = Range(newRowsAddress)
ColumnLetter = Split(Cells(1, 5 + newRows.Rows.Count).Address, "$")(1)
newRows.Columns("E:E").Value = Application.Transpose(previousRow.Columns("F:" & ColumnLetter).Value)
' Range("A5").Select
' Selection.Copy
' Range("D6:D9").Select
' ActiveSheet.Paste
newRows.Columns("D:D").Value = Application.Transpose(previousRow.Columns("A:A").Value)
' Range("C6").Select
' Application.CutCopyMode = False
' ActiveCell.FormulaR1C1 = "10000"
' Range("C7").Select
' ActiveCell.FormulaR1C1 = "20000"
' Range("C8").Select
' ActiveCell.FormulaR1C1 = "30000"
' Range("C9").Select
' ActiveCell.FormulaR1C1 = "40000"
' Range("C10").Select
j = 1
For i = newRows.Rows(1).Row To newRows.Rows(newRows.Rows.Count).Row
Range("C" & i) = j * 10000
j = j + 1
Next i
End Sub
Two New Rows
or Seven New Rows


Try using the "Use Relative References" option when recording your macro.

Related

I need help truncating characters beyond 40 in the one column in VBA

My code fails to truncate anything beyond 40 characters when i run it. Any suggestions on what line I can use. The code is an xlam. I am trying to truncate anything in column G I tried to put in formula left(F2, 40). Maybe i am using a wrong formula? or there is another way to fix it. Please let me know. Here is the Code I have so far:
Option Explicit
Private Sub ProcessReport()
Dim oWB As Excel.Workbook
Dim oXLAM As Excel.Workbook
Dim oWS As Excel.Worksheet
Set oWB = ActiveWorkbook
Set oWS = ActiveSheet
Set oXLAM = Workbooks("NRPPosPay.xlam")
Call formatcols
End Sub
Sub formatcols()
Dim oWS As Excel.Worksheet
Dim LastPopulatedRow As Long
LastPopulatedRow = Range("G" & Rows.Count).End(xlUp).Row
'Delete Colums
Columns("F:H").Select
Selection.Delete Shift:=xlToLeft
'Move Colums
Columns("E:E").Select
Selection.Cut
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Columns("G:G").Select
Selection.Cut
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Columns("G:G").Select
Selection.Cut
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Columns("E:E").Select
Selection.Cut
Columns("D:D").Select
Selection.Insert Shift:=xlToRight
Columns("G:G").Select
Selection.Cut
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Columns("G:G").Select
Selection.Cut
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
'Replace in Colums
Range("G:G").Replace What:=",", Replacement:=" "
Range("C:C").Replace What:="-", Replacement:=" "
Range("E:E").Replace What:="OCK", Replacement:="IS"
Range("E:E").Replace What:="VCK", Replacement:="CN"
'Formula in Columns
Range("G2").Formula = "=left(G2, 40)"
Range("G2: " & "G" & LastPopulatedRow).FillDown
'Copy and Paste
Range("G:G").Copy
Range("F:F").PasteSpecial _
Operation:=xlPasteSpecialOperationDivide
'Delete Column
Columns("G:G").Select
Selection.Delete Shift:=xlToLeft
'Replace
Range("F:F").Replace What:=",", Replacement:=" "
'Format columns
Columns("A:A").NumberFormat = "0"
Columns("B:B").NumberFormat = "0"
Columns("C:C").NumberFormat = "#.00"
Columns("D:D").NumberFormat = "mddyyyy"
' Delete Header row
Rows(1).EntireRow.Delete
End Sub
Sub ProcessPos(control As IRibbonControl)
Call ProcessReport
End Sub

Leaving all other changes that you can do to improve the code you should replace this line
Range("G2").Formula = "=left(G2, 40)"
with this one:
Range("G2").Value = Left(Range("G2").Value, 40)
This would make your code do what you desire for cell G2 now you can use loop to do this for all cells.

I am not able to filter by Current date in excel column (AA)

I am not able to filter column (AA) Based on current date,column AA contains dates and its data type also date
please help me
[I am attching screenshot of column AA][1]
Sub Macro3()
'
' Macro3 Macro
'
'
Dim count As Integer
count = 0
Dim dDate As Date
dDate = Format(Date, "dd/mm/yyyy")
MsgBox (dDate)
Dim j As Integer
Dim MyArr(16) As String
For j = 2 To 16
MyArr(j) = Cells(j, 29).Value
Next
Dim nFirst As Long, nLast As Long, i As Long
Dim item As String
Dim arrTemp() As String
Dim Coll As New Collection
'Get First and Last Array Positions
nFirst = LBound(MyArr)
nLast = UBound(MyArr)
ReDim arrTemp(nFirst To nLast)
'Convert Array to String
For i = nFirst To nLast
arrTemp(i) = CStr(MyArr(i))
Next i
'Populate Temporary Collection
On Error Resume Next
For i = nFirst To nLast
Coll.Add arrTemp(i), arrTemp(i)
Next i
Err.Clear
On Error GoTo 0
'Resize Array
nLast = Coll.count + nFirst - 1
ReDim arrTemp(nFirst To nLast)
'Populate Array
For i = nFirst To nLast
arrTemp(i) = Coll(i - nFirst + 1)
Next i
For i = 1 To nLast
MsgBox (arrTemp(i))
Selection.AutoFilter
MsgBox (Cells(2, 27).Value)
ActiveSheet.Range("$A$1:$AN$16").AutoFilter Field:=27, Operator:= _
xlFilterValues, Criteria2:=Array(1, dDate)
ActiveSheet.Range("$A$1:$AN$16").AutoFilter Field:=29, Criteria1:= _
arrTemp(i)
Selection.Copy
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:N").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("C:N").Select
Selection.Delete Shift:=xlToLeft
Columns("C:E").Select
Range("E1").Activate
Selection.Delete Shift:=xlToLeft
Columns("E:P").Select
Selection.Delete Shift:=xlToLeft
Range("A1:C1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
count = count + 1
Next
End Sub
[1]: https://i.stack.imgur.com/wX8zt.png

Excel 2010 Macros

I work with excel 2010 and have created a macro to copy a row of text data, transpose it into a column and then add commas after each value. Now I want the same macro to also find a pre-determined value in the column and replace it with another pre-determined value. Here is what I have so far...
Sub Macro2()
'
' Macro2 Macro
'
' Keyboard Shortcut: Ctrl+q
'
Range("E2:CL6").Select
Selection.Copy
Range("A11").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
x = 1
Do While Cells(11, x) <> ""
Cells(11, x).Select
Set Rng = Range(Selection, Selection.End(xlDown))
For Each cell In Rng
cell.Value = cell.Value + ","
Next
x = x + 1
Loop
Application.CutCopyMode = False
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells.Select
Cells.EntireColumn.AutoFit
Range("B1").Select
ActiveCell.FormulaR1C1 = "user id"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Pin"
Range("B2").Select
End Sub

Here is your code (a bit more cleaner without the .Select) :
Sub Macro2()
'
' Macro2 Macro
'
' Keyboard Shortcut: Ctrl+q
'
Range("E2:CL6").Copy
Range("A11").PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True
x = 1
Do While Cells(11, x) <> ""
Set Rng = Range(Cells(11, x), Cells(11, x).End(xlDown))
For Each cell In Rng
cell.Value = CStr(cell.Value & ",")
cell.Value = Replace(cell.Value, "Fixed Income Research Group", "SS FixedIncomeResearch")
cell.Value = Replace(cell.Value, "Fixed Income Trading Group", "SS FixedIncomeTrading")
Next
x = x + 1
Loop
Application.CutCopyMode = False
Columns("B:B").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove
Columns("B:B").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove
Cells.EntireColumn.AutoFit
Range("B1").FormulaR1C1 = "user id"
Range("C1").FormulaR1C1 = "Pin"
End Sub

excel macro insert text in every other row

i have an excel macro that i recorded, but i want to do it in every row. Can someone help me out with it?
Sub Macro1()
'
' Macro1 Macro
'
'
Rows("3:3").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1:C1").Select
Selection.Copy
Range("A4").Select
ActiveSheet.Paste
Rows("6:6").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1:C1").Select
Range("C1").Activate
Selection.Copy
Range("A7").Select
ActiveSheet.Paste
End Sub
Something like this
BEFORE:
http://i58.tinypic.com/2i9ko5s.png
AFTER
http://tinypic.com/view.php?pic=wa6a8n&s=8
SOLUTION
Sub test()
Dim Last As Integer, emptyRow As Integer
Last = Range("A" & Rows.Count).End(xlUp).Row
For emptyRow = Last To 3 Step -1
If Not Cells(emptyRow, 1).Value = "" Then
Rows(emptyRow).Resize(2).Insert
Range(Cells(emptyRow + 1, "A"), Cells(emptyRow + 1, "C")).Value = Array("School Year", "Term", "Section ID")
End If
Next emptyRow
End Sub

Here is how you can do something in every other row
Sub EveryOtherRow()
Dim iRow As Integer
iRow = 2
Do While iRow < 1000
'check to see if it is an even row
If iRow Mod 2 = 0 Then
'do something
End If
iRow = iRow + 1
Loop
End Sub

Perform calculation on cells if they have data

I am a bit new to the macro's in excel and I am trying to find a way to adjust one of the macros I currently have in an excel file. I have a calculation that takes the columns D and E then subtracts D from E and adds it to the value of column B. here is the current code and also the sheet being used.
Sub InvAdj()
'
' InvAdj Macro
'
' Keyboard Shortcut: Ctrl+Shift+I
'
Columns("C:C").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("C1").Select
ActiveCell.FormulaR1C1 = "Quality"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=RC[-1]-RC[2]+RC[3]"
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C33")
Range("C2:C33").Select
Columns("C:C").Select
Selection.Copy
Columns("B:B").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=False
Columns("C:C").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("D2:E33").Select
Selection.ClearContents
Range("F1").Select
End Sub

Not sure if this is what you are trying?
Sub InvAdj()
Dim ws As Worksheet
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
.Range("B1").Value = "Quality"
For i = 2 To 33
'~~> Check if all cells have data
If Len(Trim(.Range("B" & i).Value)) <> 0 And _
en(Trim(.Range("D" & i).Value)) <> 0 And _
en(Trim(.Range("E" & i).Value)) <> 0 Then
'B = B + (E - D)
.Range("B" & i).Value = .Range("B" & i).Value + _
(.Range("E" & i).Value - .Range("D" & i).Value)
End If
Next i
End With
End Sub

Resources