I have an Excel sheet where I have different numbers in range A1 to A10. I need to take the value from the cell and add that many rows under that cell.
Lets say A1 as 3 as value and macro should add 2 rows below A1.
I have tried using "Rows" function but I couldn't find a way out.
Please help.
This should get you going. Let me know if you need any further help.
Sub CellsValue()
Dim Colm As Integer
Dim lastrow As Long, deflastrow As Long
'Get the Position of the Required column which has the numbers that it has to shift towards
Colm = WorksheetFunction.Match("Cells Value", Sheets("Sheet1").Rows(1), 0)
'Get the lastrow of that column
lastrow = ActiveSheet.Cells(Rows.Count, Colm).End(xlUp).Row
deflastrow = Application.Sum(Range(Cells(1, Colm), Cells(lastrow, Colm)))
For i = 2 To deflastrow + lastrow
Range("A" & i + 1).Select
InsertRow = Range("A" & i).Value
If InsertRow > 0 Then
InsertRow = InsertRow - 1
End If
If InsertRow = 0 Then
Range("A" & i + 1).Select
Else
For j = 1 To InsertRow
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
Next
End Sub
I have made the change. Now it will work. Kindly accept the answer if it works for you.
Alternate solution:
Sub tgr()
Dim ws As Worksheet
Dim i As Long
Const sCol As String = "A"
Set ws = ActiveWorkbook.ActiveSheet
For i = ws.Cells(ws.Rows.Count, sCol).End(xlUp).Row - 1 To 1 Step -1
With ws.Cells(i, sCol)
If IsNumeric(.Value) Then
If .Value - 1 > 0 Then .Offset(1).Resize(.Value - 1).EntireRow.Insert xlShiftDown
End If
End With
Next i
End Sub
Dim i, max, num As Integer
i = 1
max = 10
Do While i < max
Range("A" & i).Select
num = Selection.Value
Dim x As Integer
x = 0
Do While x < num
i = i + 1
Range("A" & i).Select
Selection.EntireRow.Insert
max = max + 1
x = x + 1
Loop
i = i + 1
Loop
End Sub
Related
What I need help on is to copy the previous cells text into the cell below it and add the letter A at the end of it i.e. before VP0007 after VP0007A. This should continue until all the blank cells have been incremented and it reaches the next VP0008.
Please see the images. I apologise if I am not too clear.
Before: After:
Right now I have the following code:
ActiveCell.Offset(1, 0).Select
Letter = "A"
Letters = Chr(Asc(Letter) + 1)
Number = ActiveCell.Offset(-1, 0).Value
If ActiveCell.Value = Number & Letter _ Then
ActiveCell.Offset(1, 0).Select.Value Number & Number
Else
ActiveCell.Value = Number & Letters
End If
Loop Until ActiveCell.Offset(1, 0).Value <> ""
Try this short sub procedure.
Sub fillSubseries()
Dim i As Long, a As Long, str As String
With Worksheets("sheet4")
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
If IsEmpty(.Cells(i, "A")) Then
.Cells(i, "A") = str & Chr(a)
a = a + 1
Else
a = 65
str = .Cells(i, "A").Value2
End If
Next i
End With
End Sub
Try using the below code
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Letter = "A"
For iLoop = 2 To LastRow
If ActiveSheet.Range("A" & iLoop) = "" Then
iValue = ActiveSheet.Range("A" & iLoop - 1)
iiLoop = iLoop
Do
If ActiveSheet.Range("A" & iiLoop) = "" Then
ActiveSheet.Range("A" & iiLoop) = iValue & Letter
Letter = Chr(Asc(Letter) + 1)
Else
Letter = "A"
Exit Do
End If
iiLoop = iiLoop + 1
Loop
iLoop = iiLoop - 1
End If
Next
This code should handle cases where you have more than 26 blank rows and increment past the letter "Z".
Sub FillBlanks()
Dim lastRow As Long, cnt As Long, i As Long
Dim prevItem As String
Dim ws As Worksheet
Set ws = ActiveSheet
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
prevItem = ws.Cells(2, 1).Value
cnt = 0
For i = 2 To lastRow
If ws.Cells(i, 1) = "" Then
cnt = cnt + 1
ws.Cells(i, 1).Value = prevItem & Split(Cells(1, cnt).Address(True, False), "$")(0)
Else
prevItem = ws.Cells(i, 1)
cnt = 0
End If
Next i
End Sub
Alternate:
Sub tgr()
Dim ws As Worksheet
Dim aData As Variant
Dim sTemp As String
Dim sLetter As String
Dim i As Long, j As Long
Set ws = ActiveWorkbook.ActiveSheet
With ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
aData = .Value
End With
For i = LBound(aData, 1) To UBound(aData, 1)
If Len(Trim(aData(i, 1))) > 0 Then
sTemp = Trim(aData(i, 1))
j = 0
Else
j = j + 1
sLetter = Replace(ws.Cells(1, j).Address(0, 0), 1, vbNullString)
aData(i, 1) = sTemp & sLetter
End If
Next i
ws.Range("A2").Resize(UBound(aData, 1)).Value = aData
End Sub
If you need a pure formula solution, you may try below steps (The first row of your data should be A2, not A1):
First we need a dummy column in order to fill in the blank rows. Use below formula on B2 and copy it down through the last row of column A:
=IF(A2<>"",A2,B1)
Then we will create the final values on column C. Add below formula to C2 and copy down:
=IF(A2<>"",A2,IF(ISNUMBER(VALUE(RIGHT(C1,1)))=TRUE,C1&"A",B2&CHAR(CODE(RIGHT(C1,1))+1)))
Basically we first filled in the blank rows with repeating values on column B. Then copied Col:A value to Col:C if Col:A is not blank. If Col:A is blank and upper row (Col:C) value's last character is numeric we add "A" to that value. If the last character is a letter than we concatenate the next letter with Col:B value.
You should have something like below, when everything is OK:
Over the school holidays I was tasked with creating code that would output the Fibonacci sequence up to a certain number (in this case, the number I was given was 100000). Then, from that, I was ordered with deleting the cells that had even numbers, showing only cells that were odd. I have tried and tried many different method of doing both, but nothing seems to be working for me. Here is the code I was using:
Sub fib()
Dim x As Long
x = 100000
Range("A1") = 0
Range("A2") = 1
Do
If Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Value + _
Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(-1, 0).Value >= x _
Then Exit Sub
Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 0).FormulaR1C1 = _
"=R[-1]C+R[-2]C"
Loop
For Each Cell In Range("A1:A30")
If Cell.Row Mod 2 = 0 Then
Rows(Cell.Row).ClearContents
End If
Next
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End Sub
Now, I understand there may be a few problems with my code. The main one I see is in the first block, where instead of just inputting the numbers in to the cell, it instead inputs the way it would be calculated (for example, cell A10's value is just given as =A9+A8). I am not sure if this would cause an error in the second part of the code, where it looks for cell values so it can delete whether it is even. Could I please have some assistance on this matter? It would be much appreciated, as I've been struggling with it for the past few days now. Any help is appreciated! :)
Try the code below.
Sub fib()
Dim x As Long
Dim lRow As Long
x = 100000
Range("A1") = 0
Range("A2") = 1
Do
If Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Value + _
Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(-1, 0).Value >= x _
Then Exit Sub
Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 0).FormulaR1C1 = _
"=R[-1]C+R[-2]C"
Columns("A:A").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Loop
With ActiveSheet
lRow = WorksheetFunction.Max(Range("A65536").End(xlUp).Row)
For i = lRow To 2 Step -1
If .Cells(i, "A") Mod 2 = 0 Then
Rows(i).Delete
End If
Next i
End With
End Sub
Generate 30 values using formulas, then freeze those values (remove formulas), then remove any even values or values that exceed the max:
Sub fib()
Dim xMax As Long: xMax = 100000
Range("A1").Value = 0: Range("A2").Value = 1
With Range("A3:A30")
.Formula = "=A1+A2" ' generate using formula
.Value = .Value ' remove formulas and freeze values
End With
' now remove even values and values that exceed the xMax
' Remember to iterate backward when the loop involves deleting
Dim i As Long
For i = Cells(Rows.count, "A").End(xlUp).Row To 3 Step -1
If Cells(i, "A").Value Mod 2 = 0 Or _
Cells(i, "A").Value > xMax Then Rows(i).Delete
Next
End Sub
All this code seems fancier than it needs to be. Does this work?
The Do While..Loop builds your sequence cell by cell in column A up to 100,000.
The For Loop then runs through the list cell by cell and deletes even numbers.
Sub Fib()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim r As Long, x As Long, y As Long, z As Long, i As Long
Dim cell As Range
r = 1
x = 1
y = 0
z = 1
Do While z <= 100000
ws.Range("A" & r).Value = z
r = r + 1
z = x + y
y = x
x = z
Loop
For Each cell In ws.Range("A1", ws.Range("A1").End(xlDown))
If cell.Value Mod 2 = 0 Then cell.EntireRow.Delete
Next cell
End Sub
I have this table about 50,000 rows long that I would like Excel to go through and assign a number or letter.
Basically I am trying to group rows of data based on their sum being greater than 1,000,000.
If cell A in that row is less than 1,000,000 it will go to the next row and add up the previous cell A to the current one, and so on. This continues until the sum of all rows >= 1,000,000. When that happens, a number is "assigned" (as in entered at the end of the rows).
Sample data:
Here is my current "pseudo" code:
For x = 2 to lastrow
y = 1
If Range("A" & x).value < 1000000 Then
'I know something needs to be entered here but I don't know what
Do while balance < 1000000
sumbalance = Range("A" & x) + Range("A" & x + 1)
'Until sumbalance >= 1000000 Then Range("A" & x).Offset(0, 2).value = y
Else
Range("A" & x).offset(0, 2).value = y + 1 '(?)
Next x
Can someone point me the in the right direction?
With 50K rows, you will likely appreciate moving the values into a variant array for processing then returning them to the worksheet en masse.
Dim i As Long, rws As Long, dTTL As Double, v As Long, vVALs As Variant
With Worksheets("Sheet2")
vVALs = .Range(.Cells(2, "A"), .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "B")).Value2
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
dTTL = dTTL + vVALs(v, 1): rws = rws + 1
If dTTL >= 10 ^ 6 Then
For i = v - rws + 1 To v
vVALs(i, 2) = rws
Next i
dTTL = 0: rws = 0
End If
Next v
.Cells(2, "A").Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
End With
It isn't clear how you wanted to end the sequence if the last set of numbers do not reach the 1M mark.
I hope i am clear in my comments, let me know if the code does what you want.
Option Explicit
Sub balance()
Dim wb As Workbook
Dim ws As Worksheet
Dim x As Double, y As Integer
Dim lastrow As Long
Dim sumbalance As Double
Dim Reached As Boolean
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") 'Change the name of the sheet to yours
lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row 'Check the last Row
For x = 2 To lastrow
y = 1 ' Number 1 will be past in column C when sumblance >= 1'000'000
Reached = False
Do
If Range("A" & x).Value < 10 ^ 6 Then ' Value less than 1'000'000
If sumbalance = 0 Then 'Start the sum balance at 0
sumbalance = Range("A" & x)
Else
sumbalance = Range("A" & x) + sumbalance 'We add the previous amount to the new one
x = x + 1
End If
Else
Range("A" & x).Offset(0, 2).Value = y ' If the number is directly >= 1'000'000
Reached = True
End If
Loop Until sumbalance >= 10 ^ 6 Or x = lastrow Or Reached = True
Range("A" & x).Offset(0, 2).Value = y 'when the Sum Balance is >= 1'000'000 so 1 is paste in column c
sumbalance = 0 'Reinitialize the balance to 0
Next x
End Sub
I want to copy data from one sheet to another with few conditions:
1. Start with row 1 and column 1 and match if the R1 C2 is not empty then copy the pair R1 C1 and R1 C2 and paste into the other sheet as a new row.
increment the counter for column and match R1 C1 with R1 C3 and so on.
increment the Row when the column counter reaches 10.
I tried the below code but gives compile error as Sub or function not defined.
Please help.
Private Sub CommandButton1_Click()
Dim x As Integer
Dim y As Integer
x = 2
y = 2
Do While Cells(x, 1) <> ""
If Cells(x, y) <> "" Then
Worksheets("Sheet1").Cells(x, 2).Copy
Worksheets("Sheet2").Activate
erow = Sheet2.Cells(Rows.Count, 1).End(xlUp) > Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet2").Rows(erow)
End If
Worksheets("Sheet1").Activate
y = y + 1
If y = 10 Then x = x + 1
End If
Loop
End Sub
You are geting that error because of > in Sheet2.Cells(Rows.Count, 1).End(xlUp) > Offset(1, 0).Row
Avoid the use of using Integer when you are working with rows. Post excel2007, the row count has increased and the Integer may not be able to handle the row number.
Avoid the use of .Activate.
Is this what you are trying? (Untested)
Note: I am demonstrating and hence I am working with the excel cells directly. But in reality, I would be using autofilter & arrays to perform this operation.
Private Sub CommandButton1_Click()
Dim wsInput As Worksheet, wsOutput As Worksheet
Dim lRowInput As Long, lRowOutput As Long
Dim i As Long, j As Long
Set wsInput = ThisWorkbook.Worksheets("Sheet1")
Set wsOutput = ThisWorkbook.Worksheets("Sheet2")
With wsInput
lRowInput = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRowInput
If .Cells(i, 2).Value <> "" Then
For j = 3 To 10
lRowOutput = wsOutput.Range("A" & wsOutput.Rows.Count).End(xlUp).Row + 1
.Range(.Range(.Cells(i, 1), .Cells(i, 1)).Address & _
"," & _
.Range(.Cells(i, j), .Cells(i, j)).Address).Copy _
wsOutput.Range("A" & lRowOutput)
Next j
End If
Next i
End With
End Sub
I have a macro which looks at a range of cells. Every other cell is either a 1 or a 0 (sign bit). Depending on the sign bit, the next cell (a normal number) is multiplied either by 1 or 0. I keep getting a run time error 1004 Application-defined or object-defined error on the body of the ElseIf of the If statement (indicated below). Not sure what I'm doing wrong. My code is in a "proof-of-concept" stage so it's still pretty hackish.
Dim N As Long
------------------------------------------
Private Sub CommandButton1_Click()
Dim x As Integer
Dim y As Integer
x = 0
y = 1
N = Application.InputBox(Prompt:="Enter value", Type:=1)
If N > Columns.Count Then
N = Columns.Count
Else
For i = 4 To 9999
Cells(1, i).ClearContents
Cells(3, i).ClearContents
Next i
End If
For i = 4 To N + 3
x = x + y
Cells(1, i) = x
Next i
For i = 4 To N + 3
If Cells(2, i) = 1 Then
Cells(2, i).Offset(0, 1).Select = Cells(2, i).Offset(0, 1).Select * -1
ElseIf Cells(2, i) = 0 Then
'This is the line with errors vvvvvvvvvvvvvvvvv
Cells(2, i).Offset(0, 1).Select = Cells(2, i).Offset(0, 1).Select * 1
End If
Next i
End Sub
That's because you're using Select. Obviously, Select and Activate don't give you values. They select or activate the cell, not different from manually clicking on them using the mouse or moving/activating to them using the keyboard or what else. Multiplying them by a value is a major no-no.
The Range property you should be looking for is Value. In any case, I think you're making it difficult because of having two loops. You really should reconsider your design pattern. In any case, here's my approach (mine's vertical, but it seems like yours is horizontal, so be clear exactly what is on your end so this can be adjusted).
Private Sub CommandButton1_Click()
Dim WS As Worksheet
Dim LastRow As Long
Dim Iter As Long
Dim CurrCell As Range
Const Col = 1
With ThisWorkbook
Set WS = .Sheets("Sheet3") 'Change as necessary.
End With
With WS
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
For Iter = 1 To LastRow 'Change as necessary.
Set CurrCell = .Cells(Iter, Col)
Select Case CurrCell.Value
Case 1
CurrCell.Offset(0, 1).Value = (CurrCell.Offset(0, 1).Value * (-1))
Case 0
CurrCell.Offset(0, 1).Value = (CurrCell.Offset(0, 1).Value * 1) 'Is this even necessary? It's an identity.
End Select
Next
End With
End Sub
Screenshot:
Let us know if this helps.