I am trying to copy and paste values on the same row, meaning i should have copied values("B3:I3") on the same row using the for loop.
I have tried Rows("J" & (i+2) & ":J") and Offset() but it didnt work.
A3 gets a value, for example, if i enter a value of 5. The for loop should return the copied values("B3:I3") 5 times. But the return values are pasted on cells J3:Q6. I needed the return values to paste from J3:Q3, and the next record from R3:Y3 for the 2nd loop and Z3: AG3 for the 3rd loop
Appreciate everyone's advises as i am vba noob.
Added comment at main post for clarity
Private Sub AddItem()
Dim TotalItem As Variant
TotalItem = Range("A3").Value - 1
Dim i As Integer
For i = 1 To TotalItem
Range("B3:I3").Copy
Rows("J" & i + 2).PasteSpecial Paste:=xlPasteValues
Next i
Application.CutCopyMode = False
End Sub
would this help instead?
Private Sub AddItem()
Dim TotalItem As Variant
TotalItem = Range("A3").Value - 1
Dim i As Integer
For i = 1 To TotalItem
Range("J3").Activate
If i = 1 Then
Range("B3:I3").Copy
ActiveCell.PasteSpecial Paste:=xlPasteValues
Else
Range("B3:I3").Copy
ActiveCell.Offset(0, (i - 1) * 8).Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues
End If
Next i
Application.CutCopyMode = False
End Sub
Sorry for not fully study the task, I hope this will do it.
Private Sub AddItem()
Dim TotalItem As Long
Dim rng As Range
With ThisWorkbook.ActiveSheet
Set rng = .Range("B3:I3")
TotalItem = ThisWorkbook.ActiveSheet.Range("A3").Value
Dim lNumberOfCells As Long
lNumberOfCells = rng.Cells.Count
Dim i As Long
For i = 1 To TotalItem
.Range("B3:I3").Offset(, i * lNumberOfCells).Value = .Range("B3:I3").Value
Next i
End With
End Sub
Related
I have a worksheet that has columns 1-8, rows 3 through the last row. I would like to loop through each cell to find out if a value of 1 is present. If it is then that row is copied and inserted for each value of 1, additionally that new row will have a text inserted in cell (13,row) then moved to the next row. This is as far as I got....thanks!
Sub Workcenter()
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
On Error GoTo 0
Dim Test As Worksheet
Set TS = Worksheets("Test")
Application.DisplayAlerts = True
For k = 1 To 8
For j = 4 To TS.Cells(Rows.Count, k).End(xlUp).Row
If TS.Cells(j, k).Value = 1 Then TS.Cells.Activate
'TS.Cells.Activate.Row.Select
Rows(ActiveCell.Row).Select
Selection.Copy
Selection.Insert Shift:=xlDown
'ShopOrderNumRow = j
Next j
Next k
End Sub
Will try giving some example knowing that I still don't understand how the inserting is occurring for each cell of a row.
Providing more detail, or example of before/after in your post may help.
As for an example, since you're marking only a single cell in each row, I would suggest Find() for value of 1 to determine if you need to write to that specific cell.
'untested code
sub test()
toggle false
dim rowNum as long
for rowNum = firstRow to lastRow Step 1
with sheets(1)
with .range(.cells(rowNum,1),.cells(rowNum,8))
dim foundCell as range
set foundCell = .find(1)
if not foundCell is nothing then .cells(rowNum,13).value = "text"
end with
end with
next iterator
toggle true
end sub
private sub toggle(val as boolean)
with application
.screenupdating = val
.enableevents = val
end with
end sub
Edit1: Looks like countif() may be the saviour here.
Edit2: Tested code input (untested code part of Edit1)
Sub test()
Dim lastRow As Long: lastRow = 10
Dim firstRow As Long: firstRow = 1
toggle False
Dim rowNum As Long
For rowNum = lastRow To firstRow Step -1
With Sheets(1)
Dim countRange As Range
Set countRange = .Range(.Cells(rowNum, 1), .Cells(rowNum, 8))
Dim countOfOnes As Long
countOfOnes = Application.CountIf(countRange, 1)
If countOfOnes > 0 Then
With .Rows(rowNum)
.Copy
.Offset(1).Resize(countOfOnes).Insert Shift:=xlDown
End With
.Cells(rowNum, 13).Value = "text"
End If
End With
Next rowNum
toggle True
End Sub
Private Sub toggle(val As Boolean)
With Application
.ScreenUpdating = val
.EnableEvents = val
End With
End Sub
Tested using this data:
Output from running code:
I am beginner at VBA, I am stuck plz help. In this image(linked at the end of paragraph), I am trying to insert line above the cells which contains different name than the name of upper cell. Plz tell me if there is an easier way to do this or how to apply the given if else condition to whole "G" Column...
Still I am adding my code below if you don't need the image...
Sub ScanColumn()
'Application.ScreenUpdating = False
Dim varRange As Range
Dim currentCell As String
Dim upperCell As String
Dim emptyCell As String
currentCell = ActiveCell.Value
bottomCell = ActiveCell.Offset(1, 0).Value
emptyCell = ""
Dim intResult As Integer
intResult = StrComp(bottomCell, currentCell)
Dim emptyResult As Integer
emptyResult = StrComp(currentCell, emptyCell)
'I want to apply below condition to whole G column in used range
If emptyResult = 0 Then
ActiveCell.Select
ElseIf intResult = 0 Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1).EntireRow.Insert
ActiveCell.Offset(2, 0).Select
End If
End Sub
Here you have, just call the function "evaluateColumn" and pass the parameters, as example the "trial" sub.
Function evaluateColumn(column As String, startRow As Long, wsh As Worksheet)
Dim lastRow As Long
lastRow = wsh.Range(column & wsh.Rows.Count).End(xlUp).Row
Dim i As Long: i = startRow
Do While i < lastRow
If wsh.Cells(i, column).Value <> wsh.Cells(i + 1, column).Value And wsh.Cells(i, column).Value <> "" And wsh.Cells(i + 1, column).Value <> "" Then
wsh.Range(column & i + 1).EntireRow.Insert shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
i = i + 1
lastRow = lastRow + 1
End If
i = i + 1
Loop
End Function
Sub trial()
evaluateColumn "G", 2, ThisWorkbook.Worksheets("Sheet2")
End Sub
As you can see from the difference between my answer and the one below, your question isn't entirely clear. My code is an event procedure. It will run automatically, as you select a cell within the used range of column G.
If the value of the selected cell is the same as the cell below it the next row's cell will be selected.
If there is a value in either of the two cells, a blank row will be inserted and that row's cell selected. (If you want another row enable the row below the insertion.)
If either of the above conditions are true, do nothing and proceed with the selection the user made.
In order to let this code work it must be installed in the code sheet of the worksheet on which you want the action. It will not work if you install it in a standard code module, like Module1.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim TriggerRange As Range
Dim Off As Long ' offset from Target for selection
' if more than one cell is selected choose the first cell
If Target.Cells.CountLarge > 1 Then Set Target = ActiveCell
Set TriggerRange = Range(Cells(2, "G"), Cells(Rows.Count, "G").End(xlUp))
' this code will run only if a cell in this range is selected
' Debug.Print TriggerRange.Address(0, 0)
If Not Application.Intersect(Target, TriggerRange) Is Nothing Then
Application.EnableEvents = False
With Target
If .Value = .Offset(1).Value Then
Off = 1
ElseIf WorksheetFunction.CountA(.Resize(2, 1)) Then
Rows(.Row).Insert
' Off = 1 ' or -1 to change the selection
End If
.Offset(Off).Select
End With
Application.EnableEvents = True
End If
End Sub
in the range A1 to A70, if a cell is empty/blank then delete that entire row and move the other rows underneath up
Thank you
Use following codes.
Sub RemoveDuplicate()
On Error Resume Next
Range("A1:A70").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Edit:
Sub RemoveBlankRowsInARange()
Dim rng As Range, rws As Long, i As Long
Dim LastRow As Long
' LastRow = Cells(Rows.Count, "A").End(xlUp).Row
' Set rng = ActiveSheet.Range("A2:A" & LastRow)
' rws = rng.Rows.Count
'
' For i = rws To 1 Step (-1)
For i = 100 To 1 Step (-1)
If WorksheetFunction.CountA(Rows(i)) = 0 Then Rows(i).EntireRow.Delete
Next
End Sub
#Harun24HR - Here's how I attempted at solving this problem: I recorded a macro that deletes a row and I edited that macro to do my original question, why doesn't this work, please correct it:
Sub DeleteRowWithEmptyCell()
Dim row As Integer
For row = 1 To 100 'or whatever numbers needed
If Cells(row, 1).Value() = "" Then
Rows("row:row").Select
Selection.Delete Shift:=xlUp
End If
Next row
End Sub
I have some history working with VBA, but can't seem to find the solution to this problem. I found an iteration process to select a cell, do a process, and then select the next cell and do the process again, until NULL. I am having a problem outputting each of the processes solutions into the next column. Here is what I have:
Sub Name ()
Dim X As Integer
Dim MyString as String
Application.ScreenUpdating = False
NumRows = Range("D2", Range("D2").End(xlDown)).Rows.Count
Range("D2").Select
For X = 1 To NumRows
MyString = ActiveCell.Value
MyString = Right(MyString, Len(MyString)-6)
Range("I2 to I#").Value = MyString
ActiveCell.Offset(1,0).Select
Next X
End Sub
Range("I2 to I#").Value = MyString is the line that I need help with. I need it to increment to I3, I4, I5, etc. until it reaches NumRows count.
When working with Cells the best way to loop through them is For Each Cell in Range so taking this and as comments told you to avoid selecting, this should help you:
Option Explicit
Sub Name()
Dim C As Range, MyRange As Range
Dim LastRow As Long
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("MySheet") 'Change MySheet for your working sheet name
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row on column D
Set MyRange = .Range("D2:D" & LastRow) 'declare your working range
For Each C In MyRange
If Not C = vbNullString Then .Cells(C.Row, "I") = Right(C, Len(C) - 6)
Next C
End With
Application.ScreenUpdating = True
End Sub
Another solution is Do Until. You could use this method if you dont have empty cells in the middle of your data.
Option Explicit
Sub Test()
Dim StartingPoint As Long
StartingPoint = 2 'Set the line to begin
With ThisWorkbook.Worksheets("Sheet1") 'Set the worksheet
Do Until .Cells(StartingPoint, "D").Value = "" 'Repeat the process until you find empty cell
.Cells(StartingPoint, "I").Value = Right(.Cells(StartingPoint, "D").Value, Len(.Cells(StartingPoint, "D").Value) - 6)
StartingPoint = StartingPoint + 1
Loop
End With
End Sub
I am trying to offset the active cell until a certain condition is met. What I've written is
Do While ActiveCell.Value <> Worksheets("Unit B").Range("D1").Value
ActiveCell.Offset(0, 1).Select
Loop
Can you please help me correct this ?
Giving my entire code for reference:
Private Sub CommandButton1_Click()
Dim ddsdata As Range
Dim i As Long
i = 1
Worksheets("Unit B").Select
Set ddsdata = Worksheets("Unit B").Range("E3:E35")
Worksheets("Data Sheet").Select
Worksheets("Data Sheet").Range("E1").Select
Do While ActiveCell.Offset(0, i) <> Worksheets("Unit B").Range("D1").Value
i = i + 1
Loop
ActiveCell.Offset(1, i).Select
ActiveCell.Value = ddsdata
Try below code. Avoid using Select / Activate / ActiveCell in your code. Also always refer a cell by sheetname then the cell. eg Sheet1.Range("A1") in a workbook for better results.
Private Sub CommandButton1_Click()
Dim ddsdata As Range
Dim i As Long
i = 1
Thisworkoook.Activate
Set ddsdata = Thisworkoook.Sheets("Unit B").Range("E3:E35")
Do While Worksheets("Data Sheet").Range("E1").Offset(0, i) <> Worksheets("Unit B").Range("D1").Value
i = i + 1
Loop
ActiveCell.Offset(1, i).Select
ActiveCell.Value = ddsdata
End Sub