maxRow = ws.UsedRange.EntireRow.Count
For n = 1 To maxRow
Do While Not IsEmpty(ws.Range("D" & n).Value)
ws.Range("D" & n & ":" & "E" & n).Delete shift:=xlShiftToLeft
Rows(n + 1).Insert shift:=xlShiftDown
maxRow = maxRow + 1
Loop
Next n
I was just wondering why my code always exit when n = 19 (number of original maxRow count). I added maxRow = maxRow +1 because I inserted one row so that it doesn't exit until it is finished.
What I am trying to do, is to remove the two cells (D&E) and inserting a row underneath until D&E is empty.
Thanks
You did not answer my question and I prepared an answer based on the assumption that the necessary code must replace the cells in D:E with their right neighbors (F:G) and insert a row after such a processed range. If this assumption is correct, please test the next code:
Sub testDeleteRangeInsertRow()
Dim ws As Worksheet, n As Long
Set ws = ActiveSheet
n = 2
Do While Not IsEmpty(ws.Range("D" & n).value)
ws.Range("D" & n & ":" & "E" & n).Delete Shift:=xlShiftToLeft
Rows(n + 1).Insert Shift:=xlShiftDown
n = n + 2
Loop
End Sub
If my assumption is wrong, please better explain (in words...) what do you need to accomplish...
Related
I'm making a VBA macro to concatenate a number given by the user with a previous column value. Once the loop gets to the value given by the user (the top value), the loop would start again since number one. By now my loop gets to the top value and starts from one, but every time this happened the code skip to the next cell, could you tell me why is this happening guys? (down value by default).
Sorry i'm a little bit new on VBA, here is my try:
Sub Balance()
Dim myValue As Integer
myValue = InputBox("Please, give me a number")
Range("A2").Select
Range("A:A,C:C,F:F,H:J,L:L,T:T,W:X").Delete
Range("A2").Select
firstrow = ActiveCell.Row
Selection.End(xlDown).Select
lastrow = ActiveCell.Row
For i = 1 To lastrow
If Range("M" & i) = "AB" Then
For j = 1 To myValue
watcher = j
Range("N" & i) = "TV" & " " & Range("M" & i) & " " & watcher
i = i + 1
Next j
End If
Next i
End Sub
This the output with the number 10 as input (Column N):
I would like to reach this goal:
You already have your answer by Vandear explaining why the row is getting skipped. However here is an alternative way using only one loop to achieve what you want. But before that couple of suggestions
Suggestions:
Use Option Explicit and declare your variables. You may want to see Optimizing the VBA Code and improve the performance
Avoid the use of Select/Activate You may want to see How to avoid using Select in Excel VBA
Avoid the use of xlDown to get the last row. You may want to see Finding Last Row
When accepting number from users, use Application.InputBox with a Type:=1 instead of just InputBox. This way you will only restrict numbers.
Is this what you are trying?
Code:
Option Explicit
Sub Balance()
Dim ws As Worksheet
Dim lRow As Long
Dim i As Long, counter As Long
Dim myValue As Long
myValue = Application.InputBox(Prompt:="Please, give me a number", Type:=1)
If myValue < 1 Then Exit Sub
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> For demonstration below. I did not use this line below. But
'~~> If you need to delete those columns then use it this way
.Range("A:A,C:C,F:F,H:J,L:L,T:T,W:X").Delete
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your counter
counter = 1
For i = 1 To lRow
If .Range("M" & i) = "AB" Then
Range("N" & i) = "TV" & " " & .Range("M" & i).Value2 & " " & counter
counter = counter + 1
'~~> Reset your counter if it crosses user input
If counter > myValue Then counter = 1
End If
Next i
End With
End Sub
In action:
Couple of things before I answer your problem:
It's advisable to declare your variables for better structure:
Dim i As Integer, j As Integer, MyValue As Integer, firstrow As Integer, lastrow As Integer
You can skip the selection of a cell and directly reference it:
firstrow = Range("A2").Row
lastrow = Range("A2").End(xlDown).Row
The Answer to your Problem:
When the code exits the for-next loop for j, i is increased by 1 (i=i+1), and then it will be increased again by 1 when it proceeds to the next i line. This is the reason why it skips to the next row. So after the for-next loop for j, you need to decrease i by 1 before proceeding to the for-next loop for i.
For i = 1 To lastrow
If Range("M" & i) = "AB" Then
For j = 1 To myValue
watcher = j
Range("N" & i) = "TV" & " " & Range("M" & i) & " " & watcher
i = i + 1
Next j
i=i-1 <-------
End If
Next i
Variance Table Sample I'm working on an Excel Macros (VBA) to look through every 3rd cell of each row in a data set and perform a copy paste action based on conditions (Please see the code at the bottom).
The source data is in a another worksheet (Variance). It has 1300+ IDs (rows) and 3 columns for each value component (col 1 - value 1, col 2 - value 2, and col 3 - the difference between the 2 values) and likewise there are 500+ columns.
My code basically looks through every third column (the difference column) of each row to find out if the value is a number, not equal to zero, and if it's not an error (there are errors in the source sheet). If yes, it copies the Emp ID, the column Name, and both the values into another worksheet called vertical analysis (one below the other).
The code works fine, but it takes 6 to 7 minutes for a data set with 1000+ rows and 500+ columns.
Can someone please tell me if there is a faster way to do this than to loop through each row?
Please let me know if you need more information. Thanks in advance.
Code:
Sub VerticalAnalysis()
Dim EmpID As Range
Dim i As Long
Dim cell As Range
Dim lastrow As Range
Dim LastCol As Long
Dim curRow As Long
Dim c As Long
Set lastrow = ThisWorkbook.Worksheets("Variance").Cells(Rows.Count, 2).End(xlUp)
Set EmpID = ThisWorkbook.Worksheets("Variance").Range("B4", lastrow)
LastCol = ThisWorkbook.Worksheets("Variance").Cells(3, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
MsgBox "Depending on the size of the record, your excel will not respond for several minutes during Vertical Analysis. Please don't close the workbook", , "Note: Please Don't Close the Workbook"
Worksheets("Vertical").Select
Range("B3", "H" & Rows.Count).ClearContents
Range("B3", "H" & Rows.Count).ClearFormats
ThisWorkbook.Worksheets("Variance").Select
c = 1
For Each cell In EmpID
i = 2
Do Until i >= LastCol
cell.Offset(0, i).Select
If IsError(ActiveCell) Then
ElseIf ActiveCell <> "" Then
If IsNumeric(ActiveCell) = True Then
If ActiveCell <> 0 Then
cell.Copy
Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(-c, -2).Copy
Worksheets("Vertical").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -2).Copy
Worksheets("Vertical").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -1).Copy
Worksheets("Vertical").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If
End If
i = i + 4
Loop
c = c + 1
Next cell
ThisWorkbook.Worksheets("Vertical").Select
Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Row - 2 & " Components have variations", , "Success!"
Application.ScreenUpdating = True
End Sub
You might try to use SQL. In order to learn how to use sql in EXCEL VBA, I suggest you to follow this tuto and to apply your learn on your macro. They will be faster =)
https://analystcave.com/excel-using-sql-in-vba-on-excel-data/
Better not to hit the sheet so many times.
Below is tested and should run in a few seconds, but you may need to tweak the column positions etc:
Sub VerticalAnalysis()
Const BLOCK_SIZE As Long = 30000
Dim lastrow As Long
Dim LastCol As Long
Dim c As Long, wsVar As Worksheet, wsVert As Worksheet, n As Long
Dim data, r As Long, empId, v, rwVert As Long, dataVert, i As Long
Set wsVar = ThisWorkbook.Worksheets("Variance")
Set wsVert = ThisWorkbook.Worksheets("Vertical")
lastrow = wsVar.Cells(Rows.Count, 2).End(xlUp).Row
LastCol = wsVar.Cells(3, Columns.Count).End(xlToLeft).Column
'get all the input data as an array (including headers)
data = wsVar.Range("A3", wsVar.Cells(lastrow, LastCol)).Value
'clear the output sheet and set up the "transfer" array
With wsVert.Range("B3", "H" & Rows.Count)
.ClearContents
.ClearFormats
End With
rwVert = 3 'first "vertical" result row
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4) 'for collecting matches
i = 0
n = 0
For r = 2 To UBound(data, 1) 'loop rows of input array
empId = data(r, 2) 'colB ?
c = 7 'first "difference" column ?
Do While c <= UBound(data, 2)
v = data(r, c)
If Not IsError(v) Then
If IsNumeric(v) Then
If v > 0.7 Then
i = i + 1
n = n + 1
dataVert(i, 1) = empId
dataVert(i, 2) = data(1, c) 'header
dataVert(i, 3) = data(r, c + 2) 'value1
dataVert(i, 4) = data(r, c + 1) 'value2
'have we filled the temporary "transfer" array?
If i = BLOCK_SIZE Then
wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
i = 0
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4)
rwVert = rwVert + BLOCK_SIZE
End If
End If
End If
End If
c = c + 4 'next difference
Loop
Next r
'add any remaining
If i > 0 Then wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
wsVert.Select
wsVert.Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & n & " Components have variations", , "Success!"
End Sub
I'm trying to create a macro that outputs all possible permutations starting with a column of some numbers where each consecutive number can't be greater than the number above it.
So, would I would like to do is to provide excel with a column of 15 values in Sheet1 ranging from 1 to 9. The values should be in descending order so that a number on a row below can never exceed the one above.
What I am trying to do is to output new permutations of this list, one new sheet per new list.
The upper limit of the values in the list would be specified so the number of permutations would be everything between the starting list and the upper limit value.
There is a condition that I can not break and that is that the value of a row below another row, can't have a greater value than the one above. There's an image that explains a bit.
So far my code is not even half way there and I feel completely lost.
I'm not even sure how to go about thinking about this problem let alone coding it.
Any input would be greatly appreciated.
Sub
doSomeStuff()
Dim maxNotch, startNotch, Counter As Integer
Dim shit As Range
maxNotch = 3
startNotch = ThisWorkbook.Sheets("Sheet1").Cells(2, 2)
Counter = startNotch
sheetnumber = 2
For j = st
artNotch To maxNotch
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Sheet" & sheetnumber
ThisWorkbook.Sheets("Sheet" & sheetnumber).Cells(2, 2).Value = Counter
For i = 1 To 3
ThisWorkbook.Sheets("Sheet" & sheetnumber).Cells(i + 1, 1).Value = 2 + i
If ThisWorkbook.Sheets("Sheet" & sheetnumber).Cells(i + 1, 2).Value <> Counter Then
k = Counter - ThisWorkbook.Sheets("Sheet" & sheetnumber - 1).Cells(i + 1, 2).Value
Debug.Print k
End If
Next i
sheetnumber = sheetnumber + 1
Counter = Counter + 1
Next j
Application.DisplayAlerts = True
End Sub
Function pop()
(ByVal j As Integer, k As Integer)
For i = 1 To 3
ThisWorkbook.Sheets("Sheet" & j + 1).Cells(i + 1, 1).Value = 2 + i
ThisWorkbook.Sheets("Sheet" & j + 1).Cells(2, 2).Value = Counter
If ThisWorkbook.Sheets("Sheet" & j + 1).Cells(i + 1, 2).Value <> Cou
nter Then
ThisWorkbook.Sheets("Sheet" & j + 1).Cells(i + 1, 2).Value = ThisWorkbook.Sheets("Sheet" & j).Cells(i + 1, 2).Value
End If
Next i
End Function
Example from my comment, to account for the ordering:
dim pc as long, ws as worksheet
for each ws in worksheets
with ws
If ws.name <> "sourcedatasheet" then
.cells(2,2).resize(pc).value = "" 'export your list; pc = permutation count
.Range(.Cells(1,2),.Cells(pc+1,2)).Sort key1:=.Cells(1,2), order1:=xlDescending, Header:=xlYes 'used a header because row 1 is blank
end if
end with
next
Edit1:
Adding an if-statement to account for some specific sheet to not be included
I am trying to identify a specific range in column-A and concatenate two cells within the specific range and delete the empty cell. I have been successful in putting a code together and it does the job very well. But, I don't know how to loop it to identify next range. Any help would be appreciated.
As per below image and code, First, I am finding and selecting a range between two (MCS) in column-A with a condition that, if the rows are more than 8 between two MCS. Then I am concatenating first 2 cells immediately after MCS and delete the empty row.
The below code works well for first range but I am unable to loop to identify next range from row 22 to 32 and perform concatenations.
I dont know how to loop in column-A and select ranges and concatenate. Any help would be much appreciated. Thanks
Sub MergeStem()
Dim findMCS1 As Long
Dim findMCS2 As Long
Dim myCount As Integer
Dim myStems As Long
Dim mySelect As Range
Dim c As Range
findMCS1 = Range("A:A").Find("MCS", Range("A1")).Row
findMCS2 = Range("A:A").Find("MCS", Range("A" & findMCS1)).Row
myCount = Range("A" & findMCS1 + 1 & ":A" & findMCS2 - 1).Cells.Count
Range("B1").Value = myCount
MsgBox "Number of rows =" & myCount
Set mySelect = Selection
If myCount > 8 Then
myStems = Range("A" & findMCS1 + 2 & ":A" & findMCS2 - 9).Select
Set mySelect = Selection
For Each c In mySelect.Cells
If firstcell = "" Then firstcell = c.Address(bRow, bCol)
sArgs = sArgs + c.Text + " "
c.Value = ""
Next
Range(firstcell).Value = sArgs
End If
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Can you try this? Ordinarily, Find would be the way to go but because you are deleting rows it's hard to keep track of which cells you've found.
Sub x()
Dim r As Long, n1 As Long, n2 As Long
With Range("A1", Range("A" & Rows.Count).End(xlUp))
For r = .Count To 1 Step -1
If .Cells(r).Value = "MCS" Then
If n1 = 0 Then
n1 = .Cells(r).Row
Else
n2 = .Cells(r).Row
End If
If n1 > 0 And n2 > 0 Then
If n1 - n2 > 9 Then
.Cells(r + 1).Value = .Cells(r + 1).Value & .Cells(r + 2).Value
'.Cells(r + 2).EntireRow.Delete
'Call procedure to delete row
End If
n1 = n2
n2 = 0
End If
End If
Next r
End With
End Sub
New to this so bear with me.
I want to automatically insert a certain number or rows based on a value in another column. Can this be done?
eg
Container Lifts
B0237 1
B0238 7
B0239 7
A8783 2
So the containers would be split by the number of lifts
One for loop nested in a while loop should do your job. Why we are suing while instead of for because we can not dynamically change the limit of For loop when we add a new row in between existing data. So there you go:
Dim LastRow As Long
Dim RowAddNo As Long
LastRow = Range("A1").End(xlDown).Row
i = 2
While i <= LastRow
RowAddNo = Range("B" & i).Value
For J = 1 To RowAddNo
Rows(i + 1 & ":" & i + 1).Insert shift:=xlUp
LastRow = LastRow + 1
i = i + 1 'increasing the 'i' value to find the address for the next not empty row
Next
i = i + 1 'increasing the 'i' value to find the address for the next not empty row
Wend
PS: Do not try without i = i + 1. it goes in an endless loop :)
This will do it for you:
Sub AddRows()
Dim X As Long
For X = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1 'Work backwards when inserting or deleting rows, so much easier than incrementing numbers
Range("A" & X).Offset(1, 0).Resize(Range("B" & X).Value, 1).EntireRow.Insert 'Insert the number of rows against the target row offset by 1 ie below it
Next
End Sub