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
Related
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
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
I have the following code:
Sub test()
Dim r As Range, rng As Range
Set r = Range("a6", Range("a6").End(xlDown))
For Each rng In r
If rng <> rng.Offset(-1) Then 'if range is not
Dim ws As Worksheet
Set ws = Worksheets.Add
ws.Name = rng
Else
End If
Next rng
End Sub
This would go through the range in A6 to AXX and create a worksheets for different names. I somehow can't figure out however how to copy the content of every row into every worksheet created.
So I want all the Ticker changes being copied into the new created worksheet ticker changes.
I know there is some way with the following:
Range(Cells(rng, 1), Cells(rng, 10)).Copy
But I don't know how to paste those to different worksheet.
Can someone please advice or guide. Thanks
Also when I try to run this macro it sometimes says:
That name is already taken try a different one.
However there is no worksheet with that name.
You only need to reference/specify the sheet that you want to use.
Try this (I included an inputbox to correct the name of the sheet if it is already taken :
Sub test_Nant()
Dim r As Range, rng As Range, ws As Worksheet, aWs As Worksheet
Set aWs = ActiveSheet
Set ws = Worksheets.Add
On Error GoTo SheetRename
ws.Name = "Changes list"
GoTo KeepLooping
SheetRename:
ws.Name = InputBox("Choose another name for that sheet : ", , rng.Value)
Resume Next
KeepLooping:
With aWs
Set r = .Range(.Range("a6"), .Range("a6").End(xlDown))
For Each rng In r
If rng <> rng.Offset(-1) Then 'if range is not
.Range(.Cells(rng.Row, 1), .Cells(rng.Row, 10)).Copy Destination:=ws.Range("A1")
Else
End If
Next rng
End With
End Sub
I'm trying to write a macro to loop through every worksheet in the active workbook, and save all formulas as values. To do this, for each sheet, first I run through each pivot table, then select the table and copy & paste as values. Then I am trying to use the worksheet.activerange.value = .value method to save the rest of the cells in the sheet.
I am getting a 1004 runtime error on the line wks.UsedRange.Value = wks.UsedRange.Value.
I have two questions:
1) How can I fix my runtime error?
2) Is there a way to get .value = .value to work with pivot tables? In previous macros this has never worked with pivots, so I have to use copy and paste as below.
Many thanks for your help!
Sub LockWorkbook()
Dim pvt As PivotTable
Dim wks As Worksheet
Dim i As Integer
Dim n As Integer
n = 1
For Each wks In ActiveWorkbook.Worksheets
i = 1
For Each pvt In wks.PivotTables
wks.PivotTables(i).TableRange2.Select
With Selection
.Copy
.PasteSpecial xlValues
.PasteSpecial xlFormats
End With
i = i + 1
Next pvt
Set wks = ActiveWorkbook.Worksheets(n)
wks.UsedRange.Value = wks.UsedRange.Value
n = n + 1
Next wks
End Sub
On The King's point, you can simply copy and paste the whole sheet as values.
Sheets("Sheet1").cells.copy
Sheets("Sheet1").cells.PasteSpecial Paste:=xlPasteValues
If you wanted to throw that in a simple loop to do it to all pages it can look like:
Sub Test1()
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
ActiveWorkbook.Worksheets(I).Cells.Copy
ActiveWorkbook.Worksheets(I).Cells.PasteSpecial Paste:=xlPasteValues
Next I
End Sub
Please let me know if that helped!
Latest edit eliminates Run-time error '1004' (excludes Pivot Tables from conversion to values)
Option Explicit
Public Sub ConvertFormulasToValuesInUsedRangeExceptPivotTables()
Dim ws As Worksheet, ur As Range, cel As Range
Dim pvt As PivotTable, nonPivot As Range, isPvt As Boolean
For Each ws In ThisWorkbook.Worksheets
Set ur = ws.UsedRange
For Each cel In ur
For Each pvt In ws.PivotTables 'excludes pivot tables
isPvt = Not Intersect(cel, pvt.TableRange2) Is Nothing
If isPvt Then Exit For
Next
If Not isPvt Then
If Len(cel.Formula) > 0 Then 'excludes empty cells
If nonPivot Is Nothing Then
Set nonPivot = cel
Else
Set nonPivot = Union(nonPivot, cel)
End If
End If
End If
Next cel
nonPivot.Value = nonPivot.Value
Set nonPivot = Nothing
Next ws
End Sub
I have an excel table with several columns two of which I am interested in. What I am trying to do is filter the first column with a specific criterion and then copy the visible values from the other column into a range object. After that I need to remove duplicates. The problem is I get an error. Here's the code. There are a lot of duplicates. Please tell me what's wrong or suggest a better way to achieve the task I'm trying to do.
Sub Begin()
Dim tbl As ListObject
Set tbl = Worksheets("Sheet1").ListObjects("Table1")
WorkSheet.AutoFilterMode = False
tbl.Range.AutoFilter Field:=8, Criteria1:="DUKESTREET_II-2"
Dim rng1 As Range
Set rng1 = tbl.ListColumns("TGT CELL NAME").DataBodyRange.SpecialCells(xlCellTypeVisible)
MsgBox rng1.Count
rng1.RemoveDuplicates Columns:=1, Header:=xlNo
MsgBox rng1.Count
End Sub
You're off to a great start, but unfortunately as #siddharth-rout pointed out .RemoveDuplicates will not work on a non-contiguous range.
In this case, to collect the all the unique cell values from the "TGT CELL NAME" column, you could use a collection (MSDN link):
Sub Begin()
Dim tbl As ListObject
Dim rng1 As Range, RngIdx As Range
Dim MySheet As Worksheet
Dim UniqueTGTCells As Collection
Set MySheet = ThisWorkbook.Worksheets("Sheet1")
Set tbl = MySheet.ListObjects("Table1")
'only turn off auto filter mode if it's already set to true
If MySheet.AutoFilterMode = True Then
MySheet.AutoFilterMode = False
End If
tbl.Range.AutoFilter Field:=8, Criteria1:="DUKESTREET_II-2"
Set rng1 = tbl.ListColumns("TGT CELL NAME").DataBodyRange.SpecialCells(xlCellTypeVisible)
MsgBox rng1.Count
'populate the collection object
Set UniqueTGTCells = New Collection
For Each RngIdx In rng1
On Error Resume Next
UniqueTGTCells.Add LCase(CStr(RngIdx.Value)), LCase(CStr(RngIdx.Value))
On Error GoTo 0
Next RngIdx
'message the size of the collection
MsgBox UniqueTGTCells.Count
End Sub
Here are our message boxes:
My own solution to this old post below, in case anybody struggle again with that.
Note that I translated my working code into the posted one without testing, but I guess the idea is simple enough to be applied anyway.
Sub Begin()
Dim tbl As ListObject
Set tbl = Worksheets("Sheet1").ListObjects("Table1")
WorkSheet.AutoFilterMode = False
tbl.Range.AutoFilter Field:=8, Criteria1:="DUKESTREET_II-2"
' Sort to make sure filtered view will be contiguous
tbl.range.sort Key1:=tbl.range.cells(1,8), Order1:=xlAscending, Header:=xlYes
Dim rng1 As Range
Set rng1 = tbl.ListColumns("TGT CELL NAME").DataBodyRange.SpecialCells(xlCellTypeVisible)
MsgBox rng1.Count
' Using Areas(1) does the trick (there is only 1 area - no gaps - thanks to sorting)
rng1.Areas(1).RemoveDuplicates Columns:=1, Header:=xlNo
MsgBox rng1.Count
End Sub