I'm creating a macro loop that takes the value from column A and adds it as a prefix to the rest of the cells after column D on that row. When it reaches an empty cell, it then goes to the next row and repeats the process until column A cell is empty. I have used this code which works on the first row, but I can't seem to get it to loop to the other rows.
Sub FLOC
Dim I as Integer
Dim j as Integer
I=4
j=1
'Check that Column A is not empty to stop the Loop
While Not IsEmpty(Cells(j, 1))
If Not IsEmpty(Cells(j,i)) Then
'Select Column D in that row
Cells(j, i).Select
'Add the prefix from Column A to the rest of the Cells on the row
ActiveCell.Value = Cells(1, j).Value & ActiveCell.Value
i = i + 1
'When a empty cell is reached move the ActiveCell to next row, Column D.
Else
i = 4
j = j + 1
Endif
Wend
Sub End
Any help on the right path would be appreciated.
Thanks for the help I solved this with
Sub FLO2 ()
Dim i As Double
Dim j As Double
Dim FLOC As String
j = 1
i = 4
FLOC = Cells(j, 1)
While Not IsEmpty(FLOC)
If Not IsEmpty(Cells(j, i)) Then
Cells(j, i).Select
ActiveCell.Value = Cells(j, 1).Value & ActiveCell.Value
i = i + 1
Else
i = 4
j = j + 1
End If
Wend
Sub End
Related
I found a code that I use to insert rows based on the cell value:
Sub Add_Rows()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("F" & Rows.count).End(xlUp).Row To 1 Step -1
If Cells(r, "F").Value > 0 Then Rows(r + 1).Resize(Cells(r, "F").Value).Insert
Next r
Application.ScreenUpdating = True
End Sub
But I also need to copy the value of the cell with the same index as "F" into the inserted rows:
How can I modify the code so that rows are inserted based on the value of the range F and a value from the range H is inserted into these rows in parallel?
That is, the script should have logic: if the value of "F" is 2, two rows are inserted - and the value from the index "H" is inserted into these two new rows
In the code that I sent, I manage to insert rows based on the value from the index "F", but I can't supplement the code so that the value from the index H is inserted for each new row
Please tell me how to modify the code?
Thanks
I added a line after the .Insert that assigns the value to the "H" column of those new rows. I used the same dynamic range ideas that .Insert used to find the correct range for those new rows.
Sub Add_Rows()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("F" & Rows.Count).End(xlUp).Row To 1 Step -1
If Cells(r, "F").Value > 0 Then
Rows(r + 1).Resize(Cells(r, "F").Value).Insert
Cells(r + 1, "H").Resize(Cells(r, "F").Value).Value = Cells(r, "H").Value
End If
Next r
Application.ScreenUpdating = True
End Sub
Try something like this:
Sub Add_Rows()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("F" & Rows.Count).End(xlUp).Row To 1 Step -1
If Cells(r, 5).Value > 0 Then
Rows(r + 1).Resize(Cells(r, 5).Value).Insert
' insert h value
Cells(r + 1, 7).Value = Cells(r, 7).Value
End If
Next r
Application.ScreenUpdating = True
End Sub
Trying to loop through a sheets"data".Range"AM1:AS12" and copy the data to range beginning at BD1 as long as the data doesn't equal "#N/A"
My code works with copying the first column, but doesn't do anything with the data after that. Where am I going wrong?
Set S2 = Sheets("data").Range("AM:AM")
Set S3 = Sheets("data").Range("BD:BD")
Dim i As Integer, j As Integer
j = 1
For i = 1 To 12
If S2.Cells(i, 1).Value <> "#N/A" Then
S3.Cells(j, 2).Value = S2.Cells(i, 1).Value
j = j + 1
End If
Next i
Replace:
<> "#N/A"
By:
Not(Application.WorksheetFunction.IfNa(...))
This works when i tested it.
Sub CopyCell()
Set S2 = Sheets("data").Range("A:A")
Set S3 = Sheets("data").Range("M:M")
Dim i As Integer, j As Integer
For j = 1 To 2
For i = 1 To 12
If S2.Cells(i, j).Value <> "#N/A" Then
S3.Cells(i, j).Value = S2.Cells(i, j).Value
End If
Next i
Next j
Call DeleteBlank
End Sub
Sub DeleteBlank()
Dim x As Integer
Dim y As Integer
For y = 13 To 16 'Range numbers for the columns the data is copied to
For x = 1 To 10 ' Number of cells of data you want to loop through
If Cells(x, y).Value = "" Then
Cells(x, y).Delete Shift:=xlUp
End If
Next x
Next y
End Sub
the best thing to is not to check if it is equal to "#N/A"
The best is to check if it is an error : If Not (IsError(S2.Cells(i, 1).Value)) Then
My data includes headers. In column C, the cells sometimes contain "/" or ",". The goal is to split these cells and insert a new row underneath with every sub-string.
INPUT
OUTPUT
With the code below I have been able to replace all "," with "/". Split the cell in column C by the "/" delimiter and paste underneath. I have not been able to copy and paste the contents of the row underneath with every element in the split function array. It also seems to be pasting the split values beginning in cell C2 every time.
Sub SuspenseReport()
Dim SearchCell As Variant
Dim i As Integer
Dim cell As Range
Application.ScreenUpdating = False
Set Rng = Application.Range("C2:C1000") '*Change Last Row Value Here
vLr = ActiveCell.SpecialCells(xlLastCell).Row
For Each cell In Rng
cell = Replace(cell, ",", "/")
If InStr(1, cell, "/") <> 0 Then
SearchCell = Split(cell, "/")
For i = 0 To UBound(SearchCell)
Cells(i + 2, 2).Value = SearchCell(i)
Next i
End If
Next cell
Application.ScreenUpdating = True
End Sub
When inserting or deleting rows always work from the bottom up. To retain the order of the split value, work from last to first.
Option Explicit
Sub splitSlash()
Dim tmp As Variant, i As Long, j As Long
With Worksheets("sheet1")
.Columns("C").Replace what:=Chr(44), replacement:=Chr(47), lookat:=xlPart
For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
tmp = Split(.Cells(i, "C").Value2 & Chr(47), Chr(47))
For j = UBound(tmp) - 1 To LBound(tmp) + 1 Step -1
.Cells(i + 1, "A").EntireRow.Insert
.Cells(i + 1, "A") = .Cells(i, "A").Value2
.Cells(i + 1, "B") = .Cells(i, "B").Value2
.Cells(i + 1, "C") = tmp(j)
Next j
.Cells(i, "C") = tmp(j)
Next i
End With
End Sub
I'm trying to work out how to write a Macro to replace the current Excel formula I'm using. I've tried experimenting with cell values and offsets but my knowledge of VBA is minimal. What I need it to do is to turn a single column list like this:
Cell 1
Cell 2
Cell 3
Cell 4
Cell 5
Cell 6
Into a two-column list like this:
Cell 1 Cell 2
Cell 3 Cell 4
Cell 5 Cell 6
I feel as if it should be pretty simple to achieve, but I want to avoid blank spaces and a loop will probably be required as the length of the list is likely to change each time the macro is run. Can anybody help?
I managed to work out how to do it:
Sub splitColumn()
Range("A1").Select
Do
ActiveCell.Offset(1, 0).Select
If IsEmpty(ActiveCell.Offset(-1, 1)) Then
ActiveCell.Offset(-1, 1).Value = ActiveCell
ActiveCell.EntireRow.Delete
End If
Loop Until IsEmpty(ActiveCell)
End Sub
May be you can try with the following code:
But its a bit too long...I think it may help you in providing some ideas...
Sub Splitting()
Dim i, j, k, l As Integer
RowCount = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count
For i = 1 To RowCount Step 2
For j = 1 To 1
Cells(i, j + 1).Value = Cells(i, j).Value
Cells(i, j + 2).Value = Cells(i + 1, j).Value
Next j
Next i
Call Removeblanks
End Sub
Sub Removeblanks()
RowCount = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count
For i = 1 To RowCount
For j = 1 To 1
If (Cells(i, j + 1).Value = "") Then
Cells(i, j + 1).Delete
Cells(i, j + 2).Delete
End If
Next j
Next i
End Sub
I'm a Macro novice - just figured out how to add the developer tab, so sorry if my question is dumb. I have a list of items in Column A and quantity in Column B. I want to copy Columns A and B to Columns D and E, but only if the value in Column B > 0 - and I want them to stack, no blank spaces for the quantity = 0 ones. I found some code online:
Sub copyAboveZero()
Dim sourceRng As Range
Dim cell As Range
Dim i As Long
Set sourceRng = ActiveSheet.Range("B6:B24")
i = 6
For Each cell In sourceRng
If cell.Value > 0 Then
cell.Resize(1, 2).Copy Destination:=Range("D" & i)
i = i + 1
End If
Next cell
End Sub
The problem is that in this example, the quantity was in the first cell. This one is copying Columns B and C, and I want it to copy A and B. What do I need to change? Also, can you paste special values only? I don't want the formatting to come with it.
How about:
Sub KopyKat()
Dim N As Long, i As Long
Dim j As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 1 To N
If Cells(i, "B").Value > 0 Then
Range(Cells(i, "A"), Cells(i, "B")).Copy Cells(j, "D")
j = j + 1
End If
Next i
End Sub
EDIT#1:
This addresses your comments:
Sub KopyKat()
Dim N As Long, i As Long
Dim J As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
J = 6
For i = 6 To N
If Cells(i, "B").Value > 0 And Cells(i, "B") <> "" Then
Range(Cells(i, "A"), Cells(i, "B")).Copy
Cells(J, "D").PasteSpecial (xlValues)
J = J + 1
End If
Next i
End Sub