It might be a simple question but after hours of trying about to give up...
I want the macro to find the range from a minimum to a maximum. This range should be copied and pasted to some kind of a "summary sheet".
I was able to make the macro find the min and the max and I also got a copy-paste instruction that works.
Could somebody please help me to combine these instructions into one?
Here is my macro as far as I came:
Sub Enter_Formula()
Dim blatt
Dim sheetName As String
For i = 1 To Sheets.Count
Sheets(i).Select
Range("=Min(A59:A86):=Max(A:A)").Copy Range("C1")
Next
End Sub
Thank you!!
I'd go as follows:
Sub Enter_Formula()
Dim sht As Worksheet, summarySht As Worksheet
Set summarySht = Worksheets("Summary") '<--| change "Summary" to your actual "Summary" sheet name
For Each sht In Worksheets
If sht.Name <> summarySht.Name Then
With sht.Range("A59:A86")
.Parent.Range(.Find(what:=WorksheetFunction.Min(.Cells), lookat:=xlWhole, LookIn:=xlValues), .EntireColumn.Find(what:=WorksheetFunction.Max(.EntireColumn), lookat:=xlWhole, LookIn:=xlValues)).Copy summarySht.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
End With
End If
Next
End Sub
Might be a bit faster to evaluate the expression directly (tested):
Dim ws As Worksheet
For Each ws In Worksheets
ws.Range("Index(A59:A86,Match(Min(A59:A86),A59:A86,0)):Index(A:A,Match(Max(A:A),A:A,0))").Copy ws.Range("C1")
Next
Related
I would like to copy a range in one sheet and paste it as a value in another sheet, but just in a specific range in the next available cell in column B. Starting from B4 to B23 only.
I changed some code I found online but it's not working for me in finding the next available row. After I run the macro the first time, when I run it again and again it does nothing, and it's not working in pasting only the values either.
I tried saving the file before running the Macro again, but still it's not working.
At the end, when the range in the Print sheet is full, I would like a message box asking me to select one of the printers (not the default) on one of my servers (specifying the server path in the code like \a_server_name) and print this Print Sheet only, or clear the records in the range in the Print Sheet, or save only the Sheet Print in a new file (SaveAs) to a location I can choose on one of my servers (specifying the server path in the code \a_server_name) or simply do nothing and end the sub.
Thank you.
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets(“Data”)
Set pasteSheet = Worksheets("Print”)
copySheet.Range("J11:Q11").Copy
pasteSheet.Range("B4:I23").End(xlUp).Offset(1,0)
.PasteSpecial.xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
This will set the values equal to each other without copying/pasting.
Option Explicit
Sub Testing()
Dim wsC As Worksheet: Set wsC = ThisWorkbook.Sheets("Data")
Dim wsP As Worksheet: Set wsP = ThisWorkbook.Sheets("Print")
Dim LRow As Long
LRow = wsP.Range("B" & wsP.Rows.Count).End(xlUp).Offset(1).Row
wsP.Range("B" & LRow).Resize(wsC.Range("J11:Q11").Rows.Count, wsC.Range("J11:Q11").Columns.Count).Value = wsC.Range("J11:Q11").Value
End Sub
Modifying your code - and reducing to minimal example
Sub test()
Dim copySheet As Worksheet: Set copySheet = Worksheets("Data")
Dim pasteSheet As Worksheet: Set pasteSheet = Worksheets("Print")
copySheet.Range("J11:Q11").Copy
pasteSheet.Range("B" & pasteSheet.Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End Sub
From what i can gather, you want to copy 8 cells and paste all 8 cells to 20 rows, starting at B4. You are not clear on how you want to rerun the macro, it will just write over the data you just pasted.
The first code will copy the 8 cells into the 20 rows
With ThisWorkbook
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Range("B4:I23").PasteSpecial Paste:=xlPasteValues
End With
This second code uses a for loop to accoplish the same task, but it also will write over the previously pasted data.
Dim i As Long
With ThisWorkbook
For i = 4 To 23
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Cells(i, 2).PasteSpecial Paste:=xlPasteValues
Next i
End With
If you want to be able to reuse the macro, you will have to modify the range to be copied that allows you to select the range you want to copy. Maybe a variable that allows a user input with a InputBox.
Edit:
Dim lRow As Long
lRow = Sheets("Print").Cells(Rows.Count, 2).End(xlUp).Row
With ThisWorkbook
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Cells(lRow, 2).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
Edit #3
With ThisWorkbook
Dim lRow As Long
lRow = .Sheets("Print").Range("B" & Rows.Count).End(xlUp).Row
Sheets("Data").Range("J11:Q11").Copy
Sheets("Print").Cells(lRow, 2).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
I need to be able te
Find a value in column A
Select that value and everything above it
Offset all those values over one column
The below code does just that - however, I am trying to speed up the code execution, and copy and paste actions slow it down. Is there a way to accomplish this without the cut/paste? I'd like to stick with VBA (vice formula) since this is part of a larger procedure.
Thanks!
Sub FindValueAndAboveThenMoveOver ()
Dim sht1 as Worksheet
Set sht1 = Sheets("Convert")
sht1.Columns("A:A").Find("XXXX"), LookIn:=xlValues).Select
Range(ActiveCell.Offset(0, 0), "A1").Select
Selection.Cut
Range("B1").Select
ActiveSheet.Paste
End Sub
Nothing wrong with Cut and Paste, but you can avoid it, and avoiding Select will speed things up. Plus you should check first that you have found something to avoid an error.
Sub FindValueAndAboveThenMoveOver()
Dim sht1 As Worksheet, r As Range
Set sht1 = Sheets("Convert")
Set r = sht1.Columns("A:A").Find("XXXX", LookIn:=xlValues)
If Not r Is Nothing Then
'should add sheet references here too
With Range("A1").Resize(r.Row)
Range("B1").Resize(r.Row).Value = .Value
.ClearContents
End With
End If
End Sub
This might be slightly faster:
Sub FindValueAndAboveThenMoveOver()
Dim sht1 As Worksheet, r As Range
Set sht1 = Sheets("Convert")
With sht1
Set r = Range(.Range("A1"), .Columns("A:A").Find("XXXX", LookIn:=xlValues))
End With
r.Offset(0, 1).Value = r.Value
r.Clear
End Sub
I've been extensively researching this question but none of my findings have helped me fix my code.
I'm trying to copy all the data from worksheet2 and paste directly under the data from worksheet1 (which changes every month). This is what I have so far but every time I try to run it, it says
Runtime Error 9 'Subscript out of range'.
Sub macro8()
Sheets("worksheet2").UsedRange.Copy Destination:=Sheets("worksheet1").End(xlUp).Offset(1, 0)
End Sub
Try:
Sub macro8()
Sheets("worksheet2").UsedRange.Copy Destination:=Sheets("worksheet1").UsedRange.End(xlDown).Offset(1, 0)
End Sub
Edit:
Then do it the right way. You can change the column letter "A" with the letter of your continuous Column.
Sub macro8()
Dim Rng1 As Range, Rng2 As Range, ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("worksheet1")
Set ws2 = Worksheets("worksheet2")
Set Rng2 = ws2.UsedRange 'Copy range
Set Rng1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Offset(1, 0) 'Paste range
Rng2.Copy Destination:=Rng1 'Copy/Paste
End Sub
I am trying to make the rang is dynamic in the macro without specifying the last line x.Sheets("SheetName").Range("A2:K1000").Copyin 1000 line I want to change it to dynamic because sometimes I have less or more than that.
Try this:
Sub Test()
Dim lRow as Long
Dim sht as Worksheet
Set sht = x.Sheets("SheetName")
lRow = sht.Cells(sht.Rows.Count, 2).End(xlUp).Row
sht.Range("A2:K" & lRow).Copy
End Sub
Something like this will do the job:
Option Explicit
Public Sub TestMe()
Dim lngLastRow As Long
lngLastRow = 150
'or come up with a function from here
'https://www.rondebruin.nl/win/s9/win005.htm
With x.Worksheets("SheetName")
.Range(.Cells(2, 1), .Cells(lngLastRow, 1)).Copy
End With
End Sub
In general, last row in a given column or last column in a given row is something, that you will do quite a lot of time in VBA. Thus, it is a good idea to read this:
https://www.rondebruin.nl/win/s9/win005.htm
Typically, look for the last row containing a value from the bottom up.
with x.Sheets("SheetName")
.Range(.cells(2, "A"), .cells(.rows.count, "K").end(xlup)).Copy
'paste it somewhere
end with
I am trying to run a code that I found also here. the code is removing duplicates on each column on each spreed sheet on a workbook treating it as a separate entity. whenever I try to run the code the compiler error says "sub or function not defined" and there is a yellow highlight on the most upper part and the "LastCell" got a blue highlight. I already add the solver reference but still it gives me the same error. I just can't figure out what the problem is if it's on the code or should I add another reference.
Sub Removeduplicates()
Dim ws As Workbook
Dim lLastcol As Long
Dim lLastrow As Long
Dim i As Long
For Each ws In ThisWorkbook.Worksheets
lLastcol = LastCell(ws).Column
For i = 1 To lLastcol
lLastrow = LastCell(ws, i).Row
With ws
.Range(.Cells(1, i), .Cells(lLastrow, i)).Removeduplicates Columns:=1, Header:=xlNo
End With
Next i
Next ws
End Sub
Looks like lasy cell is the function you thought you had. We is the worksheet passed in. Thee function will use something like
Function lastcell(w as worksheet) as range
Set Lastcell=w.range("a" & w.rows.count).end(xlup)
End function
After deciphering your code snippet, this is the best that I can come up with.
Function lastCell(ws As Worksheet, _
Optional c As Variant, _
Optional r As Variant) As Range
With ws
If IsMissing(c) And IsMissing(r) Then
Set lastCell = .Cells.SpecialCells(xlCellTypeLastCell)
ElseIf IsMissing(c) And Not IsMissing(r) Then
Set lastCell = .Cells(r, .Columns.Count).End(xlToLeft)
ElseIf IsMissing(r) And Not IsMissing(c) Then
Set lastCell = .Cells(.Rows.Count, c).End(xlUp)
Else
Set lastCell = .Cells(r, c)
End If
End With
End Function
Copy that code to a module code sheet in your VBA project. It can tested with a short sub procedure like the following.
Sub test()
Dim ws1 As Worksheet
Set ws1 = ActiveSheet
Debug.Print lastCell(ws1).Address(0, 0) '<~~ last cell on worksheet
Debug.Print lastCell(ws1, 3).Address(0, 0) '<~~ last used cell in column C
Debug.Print lastCell(ws1, , 4).Address(0, 0) '<~~ last used column on row 4
End Sub
If you're referring to the solution of Darren Bartrup-Cook here, make sure to copy the function LastCell to your code as well.