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
Related
I am trying to make a loop that prints every value between two cells in a row into a single column. I would also like it to skip/ignore non integer values.
For example: Cell A5 contains 5673 and Cell B5 contains 5677. Therefore the macro would output 5673, 5674, 5675, 5676, and 5677.
I have found some useful examples for looping through each row and printing each value, but have not been able to combine the two.
To print each value between the two numbers:
[D1] = [A1].Value
ato = [B1].Value
[D1].DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=ato
To loop through every row:
LR = Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To LR
Cells(j, 1).Offset(0, 2).Value = ***Every cell value between Cells(j, 1) and Cells(j, 2)***
Next j
Before:
Desired after:
Try this. You can use SpecialCells to pick out the numerical cells, and Fill to produce the intervening sequences.
Sub x()
Dim rA As Range, rCell As Range
For Each rA In Columns(1).SpecialCells(xlCellTypeConstants, xlNumbers).Areas
For Each rCell In rA
Range("D" & Rows.Count).End(xlUp)(2).Value = rCell.Value
Range("D" & Rows.Count).End(xlUp).DataSeries Rowcol:=xlColumns, Step:=1, Stop:=rCell.Offset(, 1), Trend:=False
Next rCell
Next rA
End Sub
If you will always have these 2 columns, then you may use this code
for j = 1 to 2:for i = 1 to cells(rows.count,j).end(xlup).row
if isnumeric(cells(i,j)) then cells(rows.count,4).end(xlup).offset(1,0) = cells(i,j)
next:next
bear in mind that it will post everysingle number, if you need to delete duplicates, you may do it using range.removeduplicate
Loop through the range cell by cell; test for IsNumeric and Duplicate values. Note: this is just a test code, you should always add workbook and worksheet references
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To 2
If IsNumeric(Cells(i, j)) And Cells(i, j).Offset(, 1).Value <> Cells(i, j).Value Then
If IsEmpty(Cells(1, 4).Value) Then
Cells(1, 4) = Cells(i, j)
Else: Cells(Rows.Count, 4).End(xlUp).Offset(1) = Cells(i, j)
End If
End If
Next j
Next i
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
My code copies a text from a cell in Matrix 1 to all the cells that meet my criteria in Matrix 2. But I want it to copy it only to the first cell that meets my critiria in Matrix 2 and then stop.
Private Sub CommandButton1_Click()
Dim i As Integer
Dim j As Integer
For j = 2 To 2
For i = 21 To 21
If Cells(i, j).Value > 0 Then
Cells(i, j).Value = Cells(i, j).Value - 1
Cells(i, j).Offset(0, -1).Select
End If
'as it says - for EACH - so it copies in aLL the cells'
'I can't Change the range though, cause there will come a Loop eventually'
For Each cell In Range("a1:aap15")
If cell.Interior.ColorIndex = 6 Then
If cell.Value = "" Then
cell.Value = ActiveCell.Value
End If
End If
Next
Next
Next
End Sub
You can use the Exit For command to exit a for loop. It looks like you want to add it here:
If cell.Interior.ColorIndex = 6 Then
If cell.Value = "" Then
cell.Value = ActiveCell.Value
Exit For
End If
End If
Note: not tested. Let me know if you have any problems
i'm a complete noob in vba so i'm searching all over the net to combine the code but right now it seems i hit the great wall and can't get it right. what i wanna do are:
to sum every row above and add extra row above (somehow i get this
right)
in extra row (i said above) i want to count every cells above that have value more than zero (in excel i use simple count if formula but i cant do it in vba)
to loop the step above in another sheet in this workbook except sheet 1 (the quantity of sheets can vary depend on the input, so i believe this can be done by loop but i dont know how)
to copy the output of the step above into sheet 1
this is my code so far and since i cant do loop i did it manualy for sheet2 and sheet3. i get stuck in step 2
here is the code that've been modified taken from #NEOman' code
Sub Copy_Sum()
Dim ws As Worksheet
'Selecting the worksheets to loop through
K = 1
For Each ws In ThisWorkbook.Worksheets
'Skiping the sheet1
If ws.Name <> "Sheet1" Then
'Counting the number of rows for automation
rowscount = Cells(Rows.Count, 1).End(xlUp).Row
temp = 0
'Looping throught the cells for the calculation
For j = 2 To (rowscount)
'Counting the number of cells which value greater than zero
If Cells(j, 9) > 0 Then
temp = temp + 1
End If
Next j
'Counting the number of rows for automation
rowscount1 = Cells(Rows.Count, 1).End(xlUp).Row
temp1 = 0
For i = 2 To (rowscount1)
'Counting the number of cells which value greater than zero
If Cells(i, 10) > 0 Then
temp1 = temp1 + 1
End If
Next i
'Summing up the values which are above the current cell and in Sheet1, this inclues negative numbers as well
Cells(rowscount + 1, 9).Value = Application.Sum(Range(Cells(1, 9), Cells(rowscount, 9)))
Cells(rowscount + 2, 9) = temp
'copy ke sheet 1
Worksheets("Sheet1").Cells(K, 1).Value = Cells(rowscount + 1, 1).Value
Worksheets("Sheet1").Cells(K, 2).Value = temp
K = K + 1
Cells(rowscount1 + 1, 10).Value = Application.Sum(Range(Cells(1, 10), Cells(rowscount1, 10)))
Cells(rowscount1 + 2, 10) = temp1
'copy ke sheet 1
Worksheets("Sheet1").Cells(rowscount1 + K, rowscount1 + 1).Value = Cells(rowscount1 + 2, 1).Value
Worksheets("Sheet1").Cells(rowscount1 + K, rowscount1 + 2).Value = temp1
K = K + 1
End If
Next ws
End Sub
i know my code is a mess and i wrote comment in every step i did so that i know what the codes are doing. i use different code for column I and J but neither works :(. any help will be appreciated, thanks in advance for your attention.
===========================================================================================
the code must be run in every sheet (except sheet1) manualy, so im still trying to make the code run from sheet1 but work on any other sheet in same workbook. any help will be appreciated, thanks in advance for your attention.
Sub Copy_Sum()
Dim ws As Worksheet
'Selecting the worksheets to loop through
K = 1
For Each ws In ThisWorkbook.Worksheets
'Skiping the sheet1
If ws.Name <> "Sheet1" Then
'Counting the number of rows for automation
rowsCount = Cells(Rows.Count, 1).End(xlUp).Row
temp = 0
'Looping throught the cells for the calculation
For j = 2 To (rowsCount)
'Counting the number of cells which value greater than zero
If Cells(j - 1, 1) > 0 Then
temp = temp + 1
End If
Next j
'Summing up the values which are above the current cell and in Sheet1, this inclues negative numbers as well
Cells(rowsCount + 1, 1).Value = Application.Sum(Range(Cells(1, 1), Cells(rowsCount, 1)))
Cells(rowsCount + 1, 2) = temp
Worksheets("Sheet1").Cells(K, 1).Value = Cells(rowsCount + 1, 1).Value
Worksheets("Sheet1").Cells(K, 2).Value = temp
K = K + 1
End If
Next ws
End Sub
This is the macro i am using, it looks at a field (AS) and then depending on the number in that column it will create the same amount of rows underneath. So for example if AS has '4' it will create 4 rows containing the number 4.
I need an amendment to this so that these rows will show 1-4, 2-4, 3-4, 4-4
Sub addlabels()
Dim r As Long
For r = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(r, "AS") > 1 Then
Cells(r, 1).EntireRow.Copy
Cells(r + 1, 1).EntireRow.Resize(Cells(r, "AS").Value - 1).Insert shift:=xlDown
End If
Next r
End Sub
Here is an example image of how i need the column to display at the moment it just simply copies from the top field http://i.stack.imgur.com/p8bl8.png
May be you can try like this:
Considering the field("AS") is in cell a1 i've used the following code:
Sub addinglabels()
Dim i As Integer
cellvalue = ActiveSheet.Range("A1").Value
If (cellvalue > 1) Then
For i = 1 To cellvalue
Cells(i + 1, 1).Value = i & "--" & cellvalue
Next i
End If
End Sub