I have a template Pricelist, were there are about 2600 rows, from this based on one column you pick what products you want.
I want to copy these rows into a new sheet.
Use the following code, but does some things it shouldn't.
Any suggestions?
Private Sub CmdAdd_Click()
Dim rng As Range
Dim cel As Range
Set rng = Range("B8:B39")
For Each cel In rng
If cel.Value = "X" Then
cel.EntireRow.Select
Application.CutCopyMode = False
Selection.Copy Destination:=Sheets("NewPricelist").Range("A" & Rows.Count).End(xlDown).Offset(1, 0)
End If
Next cel
End Sub
I believe the issue you are facing is due to xlDown.
You go from rows.count (end of worksheet) and down...
If we make that xlUp then the code copies the rows to the other sheet as expected. (if that is the expected)
Private Sub CmdAdd_Click()
Dim rng As Range
Dim cel As Range
Set rng = Range("B8:B39")
For Each cel In rng
If cel.Value = "X" Then
'cel.EntireRow.Select
'Application.CutCopyMode = False
cel.EntireRow.Copy Destination:=Sheets("NewPricelist").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
Next cel
End Sub
I also commented out the select to make the code faster
I have tested your code, but by the looks of it you are pasting the row all the way down in the bottom of the worksheet. On row 1048576, and then overwriting the values.
I take it you want to paste them in an order on the top of your worksheet?
Private Sub CmdAdd_Click()
Dim rng As Range
Dim cel As Range
Dim icount As Integer
Set rng = Range("B8:B39")
icount = 0
For Each cel In rng
If cel.Value = "X" Then
icount = icount + 1
cel.EntireRow.Select
Application.CutCopyMode = False
Selection.Copy
Selection.Copy Destination:=Sheets("NewPricelist").Range("A" & 0 + icount)
End If
Next cel
End Sub
Related
I need to find certain names on a worksheet, copy the entire row once it finds said name and paste it on another worksheet.
I wrote code that finds one of the names, then copies the row and pastes it to another sheet.
Sub Macro2()
Dim StatusCol As Range
Dim Status As Range
Dim PasteCell As Range
Set StatusCol = Sheet10.Range("A1:AV1569")
For Each Status In StatusCol
If Sheet11.Range("A2") = "" Then
Set PasteCell = Sheet11.Range("A2")
Else
Set PasteCell = Sheet11.Range("A1").End(xlDown).Offset(1, 0)
End If
If Status = "Jane Thompson" Then Status.Offset(0, -4).Resize(1, 5).Copy PasteCell
Next Status
End Sub
Instead of finding only one string, the "Jane Thompson" name, I want to loop through a list of names, find each, copy the entire row where they are located and paste the row into another sheet. I have all the names on another worksheet (about 80 different names)
I managed to find code that gives me the desired output:
Sub FruitBasket()
Dim rngCell As Range
Dim lngLstRow As Long
Dim strFruit() As String
Dim intFruitMax As Integer
intFruitMax = 3
ReDim strFruit(1 To intFruitMax)
strFruit(1) = "Fruit 2"
strFruit(2) = "Fruit 5"
strFruit(3) = "Fruit 18"
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For Each rngCell In Range("A2:A" & lngLstRow)
For i = 1 To intFruitMax
If strFruit(i) = rngCell.Value Then
rngCell.EntireRow.Copy
Sheets("Inventory").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues
Sheets("Fruit").Select
End If
Next i
Next
End Sub
But instead of 3 items in the array, I had to hard code 81 names. Is there any way to pull the items of an array from another sheet?
With the names in an array you can use Match rather than looping through them.
Option Explicit
Sub FruitBasket()
Dim ws As Worksheet, wsInv As Worksheet
Dim rngCell As Range, v As Variant, arNames
Dim lngLastRow As Long, lngInvRow As Long
With Sheets("Names")
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
arNames = .Range("A2:A" & lngLastRow)
End With
Set wsInv = Sheets("Inventory")
With wsInv
lngInvRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Application.ScreenUpdating = False
Set ws = ActiveSheet
With ws
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each rngCell In .Range("A2:A" & lngLastRow)
' check if value is in array
v = Application.Match(rngCell, arNames, 0)
If IsError(v) Then
' no match
Else
' match
rngCell.EntireRow.Copy
lngInvRow = lngInvRow + 1
wsInv.Cells(lngInvRow, "A").PasteSpecial xlPasteValues
End If
Next
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
Need your help to get same objective to fill up the "null" value faster than below script .
Sub FillEmptyCell()
Dim rng As Range
Dim i As Long
Dim cell As Range
Dim sht As Worksheet
Set sht = ActiveWorkbook.Sheets("rawdata")
sht.Activate
Set rng = Range(Range("G2:G14614"), Range("G" & sht.UsedRange.Rows.Count))
For Each cell In rng
If cell.Value = "" Then cell.Value = "BLANKON"
Next
End Sub
Try,
Sub FillEmptyCell()
with workSheets("rawdata")
with .range(.cells(2, "G"), .cells(.rows.count, "G").end(xlup))
on error resume next
.specialcells(xlcelltypeblanks) = "BLANKON"
on error goto 0
end with
.Activate
end with
End Sub
I am trying to write a macro that will update all cells in a column that have the same value as the adjacent column below are before and after of what I am trying to accomplish. In this example you would update B1 and then any cells in A1 with the same value would update to the B1 value
Here is the code I am using
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim cel As Range
Set rng1 = Range("A1", Range("A2").End(xlDown))
For Each cel In rng1
If cel = Target.Offset(0, -1).Value Then
cel.Offset(0, 1).Value = Target.Value
End If
Next cel
End Sub
I am not sure if what I wrote is correct, but I keep getting out of stack space error, which I think is from the macro continuously looping every time through changing the same cells. I believe this should be possible but I am a little lost.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 2 Then Exit Sub
Application.ScreenUpdating = False
For Each cel In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
If cel = Target.Offset(, -1) Then
cel.Offset(, 1) = Target
End If
Next cel
Application.ScreenUpdating = True
End Sub
I would try to avoid looping if possible. Perhaps use a UDF instead, using the .Find() method?
Option Explicit
Function myLookup(ByVal rng As Range) As String
Application.Volatile
Dim ws As Worksheet, lookupRng As Range, retRng As Range
Set ws = rng.Parent
With ws
Set lookupRng = .Range(.Cells(1, rng.Column), .Cells(rng.Row - 1, rng.Column))
End With
Set retRng = lookupRng.Find(rng.Value, ws.Cells(1, rng.Column))
If retRng Is Nothing Then
myLookup = vbNullString
Else
With retRng
myLookup = ws.Cells(.Row, .Column + 1)
End With
End If
End Function
You would place this UDF in the worksheet as follows:
and fill down. This will prevent circular references because it will search for the cells above it only within the lookupRng.
And, the final result:
I have a working code that looks for a value and copies the entire row, pasting it to the relevant sheet.
I would like to amend the code, so that it copies the entire row above the found value, rather than the row of the value.
Can anyone suggest a simple amendment to allow me to select the row above?
Sub Prod()
Sheets("BJ").Cells.Clear
Sheets("Master").Range("A1:A2").EntireRow.Copy Destination:= _
Sheets("BJ").Range("A1")
Dim MyRange, MyRange1 As Range
Sheets("Master").Select
LastRow = Sheets("Master").Range("K65536").End(xlUp).Row
Set MyRange = Sheets("Master").Range("M1:Q325" & LastRow)
For Each c In MyRange
If c.Value = "BJ" Then
If MyRange1 Is Nothing Then
Set MyRange1 = c.EntireRow
Else
Set MyRange1 = Union(MyRange1, c.EntireRow)
End If
End If
Next
If Not MyRange1 Is Nothing Then MyRange1.Copy Sheets("BJ").[a3]
End Sub
Here is one way to copy the row directly above the ActiveCell to the next open row of another worksheet:
Sub Dural()
Dim sh2 As Worksheet, N As Long
Set sh2 = Sheets("Destynation")
N = sh2.Cells(Rows.Count, "A").End(xlUp).Row + 1
If ActiveCell.Row = 1 Then
MsgBox "Nothing above"
Exit Sub
End If
ActiveCell.Offset(-1, 0).EntireRow.Copy sh2.Cells(N, 1)
End Sub
I'm trying to determine the minimum and maximum values of a 5 cell range (C:G) for all non-blank rows in a worksheet and place the respective results in columns L and M.
I'm getting a Run-time error '1004' Application-defined or object-defined error.
Sub test()
ActiveSheet.Range("A1").Select
ActiveCell.Offset(1, 0).Select
Do While ActiveCell.Value <> Empty
ActiveCell.Offset(0, 11) = WorksheetFunction.Min(Range(ActiveCell.Offset(0, 2), ActiveCell.Offset(0, 6)))
ActiveCell.Offset(0, 12) = WorksheetFunction.Max(Range(ActiveCell.Offset(0, 2), ActiveCell.Offset(0, 6)))
ActiveCell.Offset(1, 0).Select
Loop
ActiveSheet.Range("A1").Select
End Sub
I'm pretty sure my problem is in the specification of the range but not sure what it is.
The first and last selects are just a convention I use.
The second select is to step past a header row.
The third select is to increment the row.
If there is a simpler way to do this, please let me know.
I can't reproduce the error you mention, your code seems to run as is.
That said there a many ways to improve this code
Avoid Select (as mentioned in comments)
The Application object offers Min and Max functions, no need to use WorksheetFunctions for these
Better approach to range references is a combination of Offset and Resize
Your code, refactored to used these techniques
Sub Demo()
Dim ws As Worksheet
Dim rng As Range
Dim rw As Range
' Get a reference to the source data range
Set ws = ActiveSheet
With ws
Set rng = .Cells(2, 1)
' Just in case there is only one data row
If Not IsEmpty(rng.Offset(1, 0)) Then
Set rng = .Range(rng, rng.End(xlDown))
End If
End With
' Loop the range
For Each rw In rng.Rows
rw.Offset(0, 11) = Application.Min(rw.Offset(0, 1).Resize(, 5))
rw.Offset(0, 12) = Application.Max(rw.Offset(0, 1).Resize(, 5))
Next
End Sub
That said, you can go further and use a Variant Array approach. This runs much faster than looping a range (impact will vary depending on number of data rows)
Sub Demo2()
Dim ws As Worksheet
Dim rng As Range
Dim dat As Variant
Dim res As Variant
Dim i As Long
' Get a reference to the source data range
Set ws = ActiveSheet
With ws
Set rng = .Cells(2, 1)
' Just in case there is only one data row
If Not IsEmpty(rng.Offset(1, 0)) Then
Set rng = .Range(rng, rng.End(xlDown))
End If
End With
' Set up source and result arrays
dat = rng.Offset(, 2).Resize(, 5).Value
ReDim res(1 To UBound(dat, 1), 1 To 2)
With Application
' Loop the array
For i = 1 To UBound(dat, 1)
res(i, 1) = .Min(.Index(dat, i))
res(i, 2) = .Max(.Index(dat, i))
Next
End With
' Return results to sheet
rng.Offset(0, 11).Resize(, 2) = res
End Sub
Another technique is to avoid a loop entirely by (temporarily) placing formula into the sheet in one go. This will be much faster still (for more than a few data rows)
Sub Demo3()
Dim ws As Worksheet
Dim rng As Range
Dim rw As Range
' Get a reference to the source data range
Set ws = ActiveSheet
With ws
Set rng = .Cells(2, 1)
If Not IsEmpty(rng.Offset(1, 0)) Then
Set rng = .Range(rng, rng.End(xlDown))
End If
End With
' Place formulas into sheet
rng.Offset(0, 11).FormulaR1C1 = "=Min(RC[-9]:RC[-5])"
rng.Offset(0, 12).FormulaR1C1 = "=Max(RC[-9]:RC[-5])"
' replace formulas with values (optional)
rng.Value = rng.Value
End Sub
How about this?
Sub MinAndMax()
Dim rng As Range
Set rng = Range("A2:A" & Range("A2").End(xlDown).Row)
Range("L1") = WorksheetFunction.Min(rng)
Range("M1") = WorksheetFunction.Max(rng)
End Sub
Define the range upfront
Write the min and max to the cells directly