We have a macro working via a button in Excel 2013 to insert a new row with formula from above. the Problem is when it runs and i say for example copy from row 10 the formula in the new row 11 all still read back to row 10 not 11?
Sub Loop_InsertRowsandFormulas()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Risk Input Sheet")
Dim vRows As Long
Dim lastCol As Long
Dim firstRow As Long
firstRow = InputBox("Enter Row To Start Insert From.")
vRows = InputBox("Enter Number Of Rows Required")
If firstRow = 0 Or vRows = 0 Then Exit Sub
Debug.Print firstRow
IngA = ws.Cells(5, ws.Columns.Count).End(xlToLeft).Column
For myLoop = 1 To vRows
ws.Range("A" & (firstRow + myLoop)).EntireRow.Insert
ws.Range("A" & (firstRow + myLoop) & ":BB" & (firstRow + myLoop)).Formula = ws.Range("A" & firstRow & ":BB" & firstRow).Formula
Next
End Sub
You need to do a Copy/Paste. For example, if A1 contains:
=B1+C1
running:
Sub qwerty()
Range("A2").Formula = Range("A1").Formula
End Sub
will leave A2 with =B1+C1 as well.
If you want the copied formula to "adjust" then:
Sub ytrewq()
Range("A1").Copy Range("A2")
End Sub
EDIT#1:
Rather than:
ws.Range("A" & (firstRow + myLoop) & ":BB" & (firstRow + myLoop)).Formula = ws.Range("A" & firstRow & ":BB" & firstRow).Formula
use something like:
ws.Range("A" & firstRow & ":BB" & firstRow).Copy ws.Range("A" & (firstRow + myLoop) & ":BB" & (firstRow + myLoop))
Cannot take any praise for this. Thanks Dave.
Sub Loop_InsertRowsandFormulas()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Risk Input Sheet")
Dim vRows As Long
Dim lastCol As Long
Dim firstRow As Long
firstRow = InputBox("Enter Row To Start Insert From.")
vRows = InputBox("Enter Number Of Rows Required")
If firstRow = 0 Or vRows = 0 Then Exit Sub
Debug.Print firstRow
IngA = ws.Cells(5, ws.Columns.Count).End(xlToLeft).Column
For Myloop = 1 To vRows
ws.Range("A" & (firstRow + Myloop)).EntireRow.Insert
ws.Range("N" & (firstRow) & ":AW" & (firstRow + Myloop)).FillDown
Next
End Sub
Related
New user here who is also very new to Excel VB.
At the moment, I have a macro which does what you see here.
Essentially, I have 2 columns which can sometimes have cells which contain vertically stacked lines of data in each cell. Each of those lines is split out and put into newly inserted rows below (one line of data in the cell per row).
The problem I am having now, is that while the new rows now contain data in the two columns which had to be split (34 and 35), the remaining cells are empty. I am having trouble bringing the remaining 38 columns down into the newly-created rows. You can see what I mean in the image I posted. Two new rows were created and I need to fill them with the content of row 1 (fill in to the shaded area).
Here is my code right now. The part that is commented out is me trying to fill the empty space. The un-commented code does what you see in the image.
Sub main()
Dim iRow As Long, nRows As Long, nData As Long
Dim IDVariables As Range
Dim arr As Variant
With Worksheets("UI").Columns("AH")
nRows = .Cells(.Rows.Count, 1).End(xlUp).Row
For iRow = nRows To 2 Step -1
With .Cells(iRow)
arr = Split(.Value, vbLf)
nData = UBound(arr) + 1
If nData > 1 Then
.EntireRow.Offset(1).Resize(nData - 1).Insert
.Resize(nData).Value = Application.Transpose(arr)
.Offset(, 1).Resize(nData).Value = Application.Transpose(Split(.Offset(, 1).Value, vbLf))
'Set IDVariables = Range("A" & iRow & ":AG" & iRow)
'IDVariables.Select
'Selection.Copy
'Range("A" & (iRow + 1) & ":A" & (iRow + nData -1)).Select
'Selection.Paste
End If
End With
Next iRow
End With
End Sub
Any help would be very much appreciated.
Thanks!
Tested and working fine....
Option Explicit
Sub ReCode()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LR As Long, i As Long, arr
LR = ws.Range("AH" & ws.Rows.Count).End(xlUp).Row
For i = LR To 2 Step -1
If InStr(ws.Range("AH" & i), vbLf) Then
ws.Range("A" & i + 1).EntireRow.Insert xlUp
ws.Range("A" & i).EntireRow.Copy ws.Range("A" & i + 1)
arr = Split(ws.Range("AH" & i), vbLf)
ws.Range("AH" & i) = arr(0)
ws.Range("AH" & i + 1) = arr(1)
arr = ""
End If
Next i
End Sub
I'm late doing this but I figured it out. I'll post my solution for anyone who has a similar problem.
Sub main()
Dim iRow As Long, nRows As Long, nData As Long
Dim arr As Variant
Dim IDVariables, Comments, AllocationCheck As Range
Application.ScreenUpdating = False
With Worksheets("PRM2_Computer").Columns("AH")
nRows = .Cells(.Rows.Count, 1).End(xlUp).Row
For iRow = nRows To 2 Step -1
With .Cells(iRow)
arr = Split(.Value, vbLf)
nData = UBound(arr) + 1
If nData = 1 Then
Range("AI" & iRow) = 1
Range("AK" & iRow) = "Single Industry"
End If
If nData > 1 Then
.EntireRow.Offset(1).Resize(nData - 1).Insert
.Resize(nData).Value = Application.Transpose(arr)
.Offset(, 1).Resize(nData).Value = Application.Transpose(Split(.Offset(, 1).Value, vbLf))
.Offset(, 2).Resize(nData).Value = Application.Transpose(Split(.Offset(, 2).Value, vbLf))
Set Comments = Range("AL" & iRow & ":AM" & iRow)
Comments.Copy Range("AL" & (iRow + 1) & ":AL" & (iRow + nData - 1))
Set AllocationCheck = Range("AK" & (iRow) & ":AK" & (iRow + nData - 1))
AllocationCheck.Value = Application.Sum(Range("AI" & iRow & ":AI" & (iRow + nData - 1)))
Set IDVariables = Range("A" & iRow & ":AG" & iRow)
IDVariables.Copy Range("A" & (iRow + 1) & ":A" & (iRow + nData - 1))
End If
End With
Next iRow
End With
End Sub
I am building on some code, partly cut and paste from other posts. I need to concatenate with a VBA code keeping the format and running through rows to output in last cell in each row. (Can't paste image) so hope description is clear:
In A1:D1 values are RED,BLUE,GREEN
In A2:D2 Values are YELLOW,PURPLE,ORANGE
OUTPUT IN E1 should concatenate these values, keeping font colour. Each value should have "ALT ENTR" to give line break.
Next row should be displayed in E2, and so on
'************************************************************************************
Sub test()
Dim rng As Range: Set rng = Application.Range("a1:c1") 'Not yet looping
Dim row As Range
For Each row In rng.Rows
'Debug.Print col.Column
Call concatenate_cells_formats(Cells(1, 4), rng) 'Not yet looping
Next row
End Sub
Sub concatenate_cells_formats(cell As Range, source As Range)
'Anon
Dim c As Range
Dim i As Integer
i = 1
With cell
.Value = vbNullString
.ClearFormats
For Each c In source
.Value = .Value & " " & Trim(c)
Next c
.Value = Trim(.Value)
For Each c In source
With .Characters(Start:=i, Length:=Len(Trim(c))).Font
.Name = c.Font.Name
.FontStyle = c.Font.FontStyle
.Size = c.Font.Size
.Strikethrough = c.Font.Strikethrough
.Superscript = c.Font.Superscript
.Subscript = c.Font.Subscript
.OutlineFont = c.Font.OutlineFont
.Shadow = c.Font.Shadow
.Underline = c.Font.Underline
.ColorIndex = c.Font.ColorIndex
End With
.Characters(Start:=i + Len(c), Length:=1).Font.Size = 1
i = i + Len(Trim(c)) + 1
Next c
End With
End Sub
'*****************************************************************************
Option Explicit
Sub concColour()
Dim i As Long, j As Long, s As Long, l As Long, clr As Long, vals As Variant
With Worksheets("sheet4")
For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
vals = Application.Transpose(Application.Transpose(Intersect(.Range("A:D"), .Rows(i)).Value2))
.Cells(i, "E") = Join(vals, vbLf)
s = 1
For j = LBound(vals) To UBound(vals)
l = Len(vals(j))
clr = .Cells(i, "A").Offset(0, j - 1).Font.Color
With .Cells(i, "E").Characters(Start:=s, Length:=l).Font
.Color = clr
End With
s = s + l + 1
Next j
.Cells(i, "E").Font.Size = 4
Next i
End With
End Sub
enter image description here
I think you require something like this. Change source font and formats as per your requirement.
Sub Adding_T()
Dim lena As Integer
Dim lenc As Integer
Dim lend As Integer
Dim lene As Integer
Dim LastRow As Long
Dim nrow As Long
With Worksheets("Sheet2") 'Change sheet as per your requirement
LastRow = .Cells(.Rows.Count, "A").End(xlUp).row
For nrow = 1 To LastRow
.Range("E" & nrow) = .Range("A" & nrow).Value2 & Chr(13) & Chr(10) & .Range("B" & nrow).Value2 & _
Chr(13) & Chr(10) & .Range("C" & nrow).Value2 & Chr(13) & Chr(10) & .Range("D" & nrow).Value2
lena = Len(.Range("A" & nrow).Value2)
lenc = lena + 2 + Len(.Range("B" & nrow).Value2)
lend = lenc + 2 + Len(.Range("C" & nrow).Value2)
lene = lend + 2 + Len(.Range("D" & nrow).Value2)
For i = 1 To lena
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("A" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
For i = lena + 2 To lenc
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("B" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
For i = lenc + 2 To lend
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("C" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
For i = lend + 2 To lene
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("D" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
Next
End With
End Sub
Snapshot of trial:
EDIT: OP Preferred code does not permit looping through the Range. Amended his Sub Test() to allow looping through the range.
Sub Test2()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = ThisWorkbook.ActiveSheet
Dim rng As Range
Dim row As Range
Dim rw As Long
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).row
rw = 1
For rw = 1 To LastRow
Set rng = ws.Range("A" & rw & ":C" & rw)
Call concatenate_cells_formats(Cells(rw, 4), rng)
Next
End Sub
Results are as per snapshot appended here.
This is a follow on from How do I get all the different unique combinations of 3 columns using VBA in Excel?
It almost what i need, however, my requirements is that it sums the third column which will contain figures instead of yes/no
Sub sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim col As New Collection
Dim Itm
Dim cField As String
Const deLim As String = "#"
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
cField = .Range("A" & i).Value & deLim & _
.Range("B" & i).Value & deLim & _
.Range("C" & i).Value
On Error Resume Next
col.Add cField, CStr(cField)
On Error GoTo 0
Next i
i = 2
.Range("A1:C1").Copy .Range("F1")
.Range("I1").Value = "Count"
For Each Itm In col
.Range("F" & i).Value = Split(Itm, deLim)(0)
.Range("G" & i).Value = Split(Itm, deLim)(1)
.Range("H" & i).Value = Split(Itm, deLim)(2)
For j = 2 To lRow
cField = .Range("A" & j).Value & deLim & _
.Range("B" & j).Value & deLim & _
.Range("C" & j).Value
If Itm = cField Then nCount = nCount + 1
Next
.Range("I" & i).Value = nCount
i = i + 1
nCount = 0
Next Itm
End With
End Sub
This code was originally added by
Siddharth Rout
try this (follows comments)
Option Explicit
Sub Main()
Dim i As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For i = 4 To Range("A" & Rows.Count).End(xlUp).Row '<-- change 4 and "A" to your data actual upleftmost cell row and column
dict(cells(i, 1).Value & "|" & cells(i, 2).Value) = dict(cells(i, 1).Value & "|" & cells(i, 2).Value) + cells(i, 3).Value '<--| change 3 to your actual "column to sum up" index
Next
With Range("G3").Resize(dict.Count) '<-- change "G3" to your actual upleftmost cell to start writing output data from
.Value = Application.Transpose(dict.Keys)
.TextToColumns Destination:=.cells, DataType:=xlDelimited, Other:=True, OtherChar:="|"
.Offset(, 2).Resize(dict.Count).Value = Application.Transpose(dict.Items) '<--| change 2 to your actual column offset where to start writing summed values form
End With
End Sub
So I have been tasked with creating a Spread Sheet to calculate how much time is spent in any given task. So far I have buttons set up to start and stop the clock but now i am stuck trying to add the following formula to each Stop Sub:
=text(A2-A3,HH:MM:SS)
Here is what I have so far:
'
Sub StartTask()
'
Dim lr As Long
lr = Sheets(2).Range("a" & Rows.Count).End(xlUp).Row
Sheets(2).Range("a" & lr + 1).Formula = Now()
Sheets(2).Range("b" & lr + 1) = "Task Name"
Sheets(2).Range("c" & lr + 1) = "Start"
End Sub
Sub StopTask()
Dim lr As Long
Dim lra As Range
Dim lrb As Range
'
lr = Sheets(2).Range("a" & Rows.Count).End(xlUp).Row
lra = Sheets(2).Range("a" & lr)
lrb = Sheets(2).Range("a" & lr - 1)
Sheets(2).Range("a" & lr + 1).Formula = Now()
Sheets(2).Range("b" & lr + 1) = "Task Name"
Sheets(2).Range("c" & lr + 1) = "Stop"
Sheets(2).Range("d" & lr + 1).Formula = Text(lra - lrb, "hh:mm:ss")
End Sub
The formula is to find the amount of time spent in each task by subtracting the start time from the stop time. Every time Sub StartTask is run a new row is placed in sheet two, and every time Sub StopTask is run a new row is inserted in the row below that, and so on. this means that the formula needs to be placed in the same row as all the other data from Sub StopTask. I think the problem is that i am not defining lra and lrb correctly, but I'm not really sure. How can i place the formula in column D of each StopTask row?
As per my comment:
Sub StopTask()
Dim lr As Long
Dim lra As Range
Dim lrb As Range
'
lr = Sheets(2).Range("a" & Rows.count).End(xlUp).Row
Set lra =2 Sheets(2).Range("a" & lr + 1)
Set lrb = Sheets(2).Range("a" & lr)
Sheets(2).Range("a" & lr + 1).Formula = Now()
Sheets(2).Range("b" & lr + 1) = "Task Name"
Sheets(2).Range("c" & lr + 1) = "Stop"
Sheets(2).Range("d" & lr + 1).Value = Format(lra - lrb, "hh:mm:ss")
End Sub
First if you look, you were referring to the wrong rows for your values. Second text is a worksheet function. Use format instead.
placing formula:
Sheets(2).Range("d" & lr + 1).Formula = "=Text(" & lra.Address & " - " & lrb.Address & ", ""hh:mm:ss"")"
I am new to Macros. I need excel macro code for the below logic:
col1 means column1,
col2 means column2
Sub TestDuplicates()
in worksheet,
for(each x = row) {
for(each y = row+1) {
if(x.col1 == y.col1 && x.col3 == y.col4 && x.col4 == y.col3) {
Delete y
}
}
}
End Sub
Sub deleteDuplicateRows()
Dim ws As Worksheet
Dim lastRow As Long, curRow As Long, checkRow As Long
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row - 1
For curRow = 2 To lastRow
For checkRow = curRow + 1 To lastRow
If ws.Range("A" & curRow).Value = ws.Range("A" & checkRow).Value And ws.Range("B" & curRow).Value = ws.Range("B" & checkRow).Value And ws.Range("C" & curRow).Value = ws.Range("C" & checkRow).Value Then
ws.Rows(checkRow).Delete
End If
Next checkRow
Next curRow
End Sub
Checks the current row against all remaining rows starting at row 2.
Sub TestDuplicates()
Dim ws As Excel.Worksheet
Dim lRow As Long
lRow = 1
Do While lRow <= ws.UsedRange.Rows.count
If ws.Range("A" & lRow).Value = ws.Range("A" & lRow + 1).Value And ws.Range("C" & lRow).Value = ws.Range("D" & lRow + 1).Value And ws.Range("D" & lRow).Value = ws.Range("C" & lRow + 1).Value then
ws.Rows(lRow).EntireRow.Delete
End If
lRow = lRow + 1
ws.Range("A" & lRow).Activate
Loop
End Sub
EDIT: I seem to have misunderstood your pseudocode somewhat, so this doesn't do quite what you asked. Instead, it compares each row to the row directly after it, not to all remaining rows. Since bbishopca already contributed an excellent solution to what you actually asked for, I'll just leave this here unedited in case someone finds it useful.
Sub AlmostTestDuplicates()
Dim ws As Worksheet
Dim rw As Range
Set ws = ActiveSheet
For Each rw In ws.Rows
If ws.Cells(rw.Row, 1).Value = "" Then
Exit Sub
End If
If Cells(rw.Row, 1) = Cells(rw.Row + 1, 1) _
And Cells(rw.Row, 3) = Cells(rw.Row + 1, 4) _
And Cells(rw.Row, 4) = Cells(rw.Row + 1, 3) Then
ws.Rows(rw.Row + 1).Delete
End If
Next rw
End Sub