Something is wrong with my code I can't figure out.
I'd like to copy a column C from workbook 1 of worksheet wsCopyFrom_OFP to column D in workbook 2 of worksheet wsCopyTo so that only rows with values will be copied
LastRow_OFP = wsCopyFrom_OFP.Cells(wsCopyFrom_OFP.Rows.Count, "C").End(xlUp).Row
For i = 4 To LastRow_OFP
wsCopyFrom_OFP.Cells(i, 3).Copy
erow = wsCopyTo.Cells(wsCopyTo.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
wsCopyFrom_OFP.Paste Destination:=Worksheets(wsCopyTo).Cells(erow, 1)
Next i
Help very much appreciated
Try with below code
LastRow_OFP = wsCopyFrom_OFP.Cells(wsCopyFrom_OFP.Rows.Count, "C").End(xlUp).Row
For i = 4 To LastRow_OFP
wsCopyFrom_OFP.Cells(i, 3).Copy wsCopyTo.Range("A" & wsCopyTo.Range("A" & Rows.Count).End(xlUp).Row + 1)
Next i
EDIT #1
Try with below code
LastRow_OFP = wsCopyFrom_OFP.Cells(wsCopyFrom_OFP.Rows.Count, "C").End(xlUp).Row
For i = 4 To LastRow_OFP
wsCopyFrom_OFP.Range("C" & i & ":C" & i + 3).Copy
wsCopyTo.Range("A" & wsCopyTo.Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial (xlPasteValues)
Next i
Related
i would help me about my code it compares from sheet1 two columns a,b and the duplicated transfer to sheet2 the column c
Sub COPY1()
Dim i
Dim LastRow As Long
LastRow = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Sheets("sheet1").Cells(i, "A").Value = Sheets("sheet1").Cells(i, "B").Value Then
Count = Application.WorksheetFunction.CountIf(Range("B1:B" & i), Sheets("sheet1").Cells(i, "A"))
If Count > 1 Then
Sheets("sheet1").Cells(i, "A").COPY Destination:=Sheets("sheet2").Range("B" &
Rows.Count).End(xlUp).Offset(1)
End If
End If
Next i
End Sub
Give this a try:
Sub COPY1()
Dim i As Long
Dim LastRow As Long
With Sheets("sheet1")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
v = .Cells(i, "A").Value
For j = 2 To LastRow
If v = .Cells(j, "B").Value Then
.Cells(i, "A").Copy Destination:=Sheets("sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1)
End If
Next j
Next i
End With
End Sub
Formula below just inserts the row and changing color for certain offset. I need to copy formula from previuos cells H, M, N. Any ideas?
Sub button()
LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
Range("D" & LastRow + 1).EntireRow.Insert
With Range("D" & Rows.Count).End(xlUp).Offset(1)
.Value = .Offset(-1).Value + 1
.Offset(, -1).Interior.ColorIndex = 0
.Offset(, -2).Interior.ColorIndex = 0
.Offset(, -3).Interior.ColorIndex = 0
End With
End Sub
So now it's working
Sub Prideti_produkta()
LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
Range("D" & LastRow + 1).EntireRow.Insert
Range("H" & LastRow + 1).FillDown
Range("K" & LastRow + 1).FillDown
Range("M" & LastRow + 1).FillDown
Range("N" & LastRow + 1).FillDown
With Range("D" & Rows.Count).End(xlUp).Offset(1)
.Value = .Offset(-1).Value + 1
.Offset(, -1).Interior.ColorIndex = 0
.Offset(, -2).Interior.ColorIndex = 0
.Offset(, -3).Interior.ColorIndex = 0
End With
End Sub
My raw data looks something like this;
std1
std1
deviant
std2
std1
std2
std2
deviant
The "deviants" are presented randomly and thus do not occur every nth row...
I wish to select 1 row before and 1 row after each "deviant" row so I can copy it in another spread sheet.
See code below.
We loop through each row in the column (I have assumed your data is in column A) and when the given value is found, we add the following and prior rows to our selection array. When the loop is complete, we select the rows in the array
Public Sub DeviantSelect()
Dim myRange As Range
Set myRange = Nothing
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lastRow
If Cells(i, 1) = "deviant" Then
If myRange Is Nothing Then
Set myRange = Union(Range(i - 1 & ":" & i - 1), Range(i + 1 & ":" & i + 1))
Else
Set myRange = Union(myRange, Range(i - 1 & ":" & i - 1), Range(i + 1 & ":" & i + 1))
End If
myRange.Select
End If
Next
End Sub
The below code copies the cells before and after deviant to another sheet.
Sub check()
Sheet1.Activate
Range("A1").Select
LastRow = Sheets("Sheet1").UsedRange.Rows(Sheets("Sheet1").UsedRange.Rows.Count).Row
For i = 1 To LastRow
Sheet1.Activate
If Range("A" & i).Value = "deviant" Then
Range("A" & i - 1).Select
Selection.Copy
Sheet2.Activate
LastRow2 = Sheets("Sheet2").UsedRange.Rows(Sheets("Sheet2").UsedRange.Rows.Count).Row
If LastRow2 = 1 Then
Range("A" & LastRow2).Activate
Else
Range("A" & LastRow2 + 1).Activate
End If
ActiveSheet.Paste
Sheet1.Activate
Range("A" & i + 1).Select
Selection.Copy
Sheet2.Activate
LastRow2 = Sheets("Sheet2").UsedRange.Rows(Sheets("Sheet2").UsedRange.Rows.Count).Row
Range("A" & LastRow2 + 1).Activate
ActiveSheet.Paste
End If
Next
End Sub
I don't believe this has already been asked or that anything similar has been asked. I am trying to separate my data set based on the values in a column. I would then like to insert 3 rows between them. Finally I would like to add formulas to the middle row of the three that I just added. My Frankenstein's code (made up from others bits and pieces) is:
Dim LastRow As Long
Dim i As Long
LastRow = Cells(Rows.Count, "AA").End(xlUp).Row
For i = LastRow To 2 Step -1
If i = 2 Then
'Do nothing
ElseIf Cells(i, "AA") <> Cells(i - 1, "AA") Then
Rows(i).Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
End If
Next i
LR = Range("AA" & Rows.Count).End(xlUp).Row
Range("AA1:AA" & LR & "").Interior.Color = RGB(217, 217, 217)
Range("AA" & LR + 2).Formula = "=SUM(Z2:Z" & LR & ")"
As I am sure you'll notice the summation is after the bottom row and is for the whole column.
Thank you for any help you can give
You've made no mention of what sort of formula you would 'like to add formulas to the middle row of the three that I just added' so I've left in a placeholder.
Dim LastRow As Long, i As Long, lr As Long
With Sheets("Sheet5") 'set this worksheet reference properly!
LastRow = .Cells(Rows.Count, "AA").End(xlUp).Row
For i = LastRow To 3 Step -1
If .Cells(i, "AA").Value <> .Cells(i - 1, "AA").Value Then
.Cells(i, "AA").Resize(3, 1).EntireRow.Insert
.Cells(i + 1, "AA").Formula = "=SUM(AA2:AA" & i & ")"
End If
Next i
lr = .Range("AA" & Rows.Count).End(xlUp).Row
.Range("AA1:AA" & lr).Interior.Color = RGB(217, 217, 217)
.Range("AA" & lr + 2).Formula = "=SUM(Z2:Z" & lr & ")"
End With
There is also no mention of looking for and possibly removing previous summation formula(s) at hte bottom of the column that may have been left from previous run-throughs but I would suppose that this is to be performed on raw data each time.
Good day,
I am trying to create a macro that moves a row to the bottom of the sheet based on criteria.
What i have been able to do so far is copy the row to the bottom, but this will create a duplicate row for me, where in reality i only need it to be moved.
'Moving column "Grand Total" to bottom
With Wbk4.Sheets("TEST")
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
'Loop through each row
For x = 2 To FinalRow
'Decide if to copy based on column A
ThisValue = Cells(x, 1).Value
If ThisValue = "Grand Total" Then
Cells(x, 1).Resize(1, 33).Copy
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A" & lrow + 1, "Z" & lrow + 1).PasteSpecial xlPasteAll
End If
Next x
End With
Thanks
As you've provided no sample data, it is hard to recommend a custom sort but a temporary helper column off the right side could quickly move all Grand Total rows to the bottom.
With Wbk4.Sheets("TEST")
With .Cells(1, 1).CurrentRegion
.Columns(.Columns.Count).Offset(1, 1).Resize(.Rows.Count - 1, 1).Formula = "=--(A2=""Grand Total"")"
End With
With .Cells(1, 1).CurrentRegion 'reestablish current region with new helper column
.Cells.Sort Key1:=.Columns(.Columns.Count), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
.Columns(.Columns.Count).Cells.ClearContents
End With
End With
There are two additional sort keys (maximum of three without doubling up) if you wanted to add additional sorting order(s).
Try Cells(x, 1).EntireRow.Delete or Cells(x, 1).Resize(1, 33).Delete before End If
Thanks Jeeped, it works fine !!
I Did it using another method before trying your code, and it works too!!
I am posting it below for reference in case anyone is looking for code references in the future
'Moving column B to bottom
With Wbk4.Sheets("test")
FinalRow = .Cells(rows.Count, 1).End(xlUp).Row
'Loop through each row
For x = 2 To FinalRow
'Decide if to copy based on column A
ThisValue = .Cells(x, 1).Value
If ThisValue = "Grand Total" Then
.Cells(x, 1).Resize(1, 33).Select
Selection.Cut
lRow = .Range("A" & .rows.Count).End(xlUp).Row
.Range("A" & lRow + 1, "Z" & lRow + 1).Select
ActiveSheet.Paste
End If
Next x
End With
'Delete Blank Rows
Dim i As Long
With Wbk4.Sheets("test")
For i = .Range("A" & rows.Count).End(xlUp).Row To 1 Step -1
If .Range("A" & i) = "" Then
.Range("A" & i).EntireRow.Delete
End If
Next i
End With