I have a series of variables (each declared as a range) in a VBA script as follows:
r1 = range
r2 = range
...
r100 = range
Ideally I'd like to use a for loop to select, copy, and paste (transpose) each range in succession. I'm writing my code via trial and error, and I have little familiarity with VBA. Currently I'm using a loop like the following:
For i = 0 To 99 Step 1
Dim Num As Integer
Num = i + 1
Num = CStr(Num)
Dim R As Range
R = "r" & Num
R.Select
Selection.Copy
Range("TARGET RANGE").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Next i
Can anyone help me debug this loop and/or find the best way to achieve this?
You need to Set a Range object.
Dim Num As Integer, R As Range
For i = 0 To 99 Step 1
Num = i + 1
SET R = RANGE("r" & Num)
R.Copy Destination:=Range("TARGET RANGE")
Next i
It is not entirely clear what you intend to accomplish but the above should do what is expected of it.
You can use a For Each ... In loop for this.
Dim Bag As New Collection
Dim Target As Range
Dim r As Range
Bag.Add [A1:A50]
Bag.Add [C3:F100]
Bag.Add [Sheet2!H1:L1]
Bag.Add ['[Another file.xlsx]Sheet1'!A1:B100]
Set Target = [Output!A1]
For Each r In Bag
' Size target to be the same dimensions as r transposed
Set Target = Target.Resize(r.Columns.Count, r.Rows.Count)
' transpose and copy values
Target.Value = Application.Transpose(r.Value)
' shift target down to next empty space
Set Target = Target.Offset(Target.Rows.Count)
Next
Related
The following code applies filters and selects the top 10 items in column B after some filters are applied to the table. I have been using this for many different filtered selection, but I came across a problem with one of my filter combinations.
I found that when there is only one item in column B after filtering, it doesn't copy that one cell - instead it copies the entire row and seems to be a strange selection.
When I manually add one more item to this filter (total 2), then it copies it fine. Any ideas on why this code won't work when there is only one item?
Sub top10()
Dim r As Range, rC As Range
Dim j As Long
'Drinks top 10
Worksheets("OLD_Master").Columns("A:H").Select
Selection.sort Key1:=Range("H1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Worksheets("OLD_Master").Range("A:H").AutoFilter Field:=4, Criteria1:=Array( _
"CMI*"), Operator:= _
xlFilterValues
Worksheets("OLD_Master").Range("A:H").AutoFilter Field:=5, Criteria1:="Drinks"
Set r = Nothing
Set rC = Nothing
j = 0
Set r = Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
For Each rC In r
j = j + 1
If j = 10 Or j = r.Count Then Exit For
Next rC
Range(r(1), rC).SpecialCells(xlCellTypeVisible).Copy
Worksheets("For Slides").Range("P29").PasteSpecial
Worksheets("OLD_Master").ShowAllData
End Sub
Rory helpfully points out:
If you apply Specialcells to only one cell, it actually applies to the entire used range of the sheet.
Now we know what the problem is, we can avoid it! The line of code where you use SpecialCells:
Set r = Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
Instead, set the range first, test if it only contains one cell, then proceed...
Set r = Range("B2", Range("B" & Rows.Count).End(xlUp))
' Check if r is only 1 cell
If r.Count = 1 Then
r.Copy
Else ' Your previous code
Set r = r.SpecialCells(xlCellTypeVisible)
For Each rC In r
j = j + 1
If j = 10 Or j = r.Count Then Exit For
Next rC
Range(r(1), rC).SpecialCells(xlCellTypeVisible).Copy
End If
Note, you're assuming there is even one row still visible. It might be that the .End(xlUp) selects row 1 if there is no visible data, you may want to check which row this is first too!
Aside: You really should be fully qualifying your ranges, i.e. instead of
Set r = Range("B2")
You should use
Set r = ThisWorkbook.Sheets("MySheet").Range("B2")
This will save you some confusing errors in future. There are shortcuts you can take, for example saving repetition using With blocks or declaring sheet objects.
' using With blocks
With ThisWorkbook.Sheets("MySheet")
Set r = .Range("B2")
Set s = .Range("B3")
' ...
End With
' Using sheet objects
Dim sh as Worksheet
Set sh = ThisWorkbook.Sheets("MySheet")
Set r = sh.Range("B2")
Thank you to #Rory
Specialcells
Doesn't work with one cell selected. Adapted by doing the following:
......
For Each rC In r
j = j + 1
If j = 10 Or j = r.Count Then Exit For
Next rC
If j = 1 Then
Range(r(1), rC).Copy
Else
Range(r(1), rC).SpecialCells(xlCellTypeVisible).Select
End If
Worksheets("For Slides").Range("P29").PasteSpecial
Worksheets("OLD_Master").ShowAllData
End Sub
I am trying to write a VBA code to autofill range A1:A10000 with numbers 1 to 10000 but without entering 1 in A1 and 2 in A2 to create a range.
Basically, I need a code that looks like this:
Set fillRange = Worksheets("Sheet1").Range("A1:A10000")
(1,2).AutoFill Destination:=fillRange
Of course this does not work, but you get what it.
Writing and reading to/from the worksheet are some of the slowest actions you can perform. Writing time-efficient code means doing as much in memory as you can.
Try writing all your values into an array, then writing the whole thing to the worksheet in one shot, something like this:
Sub printRange(total As Integer)
Dim i, myRange() As Integer
ReDim myRange(1 To total)
For i = 1 To total:
myRange(i) = i
Next i
'Use Transpose to shift the 1d array into a column
Worksheets("Sheet1").Range("A1:A" & UBound(myRange)).Value = _
Application.WorksheetFunction.Transpose(myRange)
End Sub
For total = 10000, this pretty much runs instantly, even on a ten year old dinosaur desktop.
Dim fillRange As Range
Dim i As Long
Set fillRange = Worksheets("Sheet1").Range("A1:A10000")
With fillRange
For i = .Cells(1, 1).Row To .Cells(.Rows.Count, 1).Row
.Cells(i, 1).Value = i
Next i
End With 'fillRange
Or with AutoFill :
With Worksheets("Sheet1")
Range("A1").Value = 1
Range("A2").Value = 2
Range("A1:A2").AutoFill Destination:=Range("A1:A10000")
End With 'Worksheets("Sheet1")
this should be fast enough
you could use the following function
Function FillNumbers(rng As Range) As Variant
Dim i As Long
ReDim nmbrs(1 To rng.Rows.Count)
For i = 1 To UBound(nmbrs)
nmbrs(i) = i
Next
FillNumbers = Application.Transpose(nmbrs)
End Function
in the following manner
With Worksheets("Sheet1").Range("A1:A10000")
.Value = FillNumbers(.Cells)
End With
Can't you use a simple loop?
For i = 1 to 10000
Worksheets("Sheet1").Cells(i, 1) = i
Next i
Dim fillRagne As Range
Set fillRange = Range(Cells(1, 1), Cells(1000, 1))
For Each cell in fillRange
cell.value = cell.Row
Next cell
I am Trying to Transpose a range of cells in Excel through VBA macro but I am getting some errors, mostly Error 91.
I am pretty new to VBA and don't have much idea about functions either.
Range(InRng).Select
Set Range1 = Selection
Dim DestRange As Range
Set DestRange = Application.WorksheetFunction.Transpose(Range1)
After going through a couple of forums, this is what I have come up with. One thing to note is that I don't have to copy them into any other cells.
What I am trying to achieve is to create a co-variance method and in the option window the user will have the option to select the range and then choose either by columns or rows, this will then affect the resulting covariance matrix.
This gets you X and X' as variant arrays you can pass to another function.
Dim X() As Variant
Dim XT() As Variant
X = ActiveSheet.Range("InRng").Value2
XT = Application.Transpose(X)
To have the transposed values as a range, you have to pass it via a worksheet as in this answer. Without seeing how your covariance function works it's hard to see what you need.
First copy the source range then paste-special on target range with Transpose:=True, short sample:
Option Explicit
Sub test()
Dim sourceRange As Range
Dim targetRange As Range
Set sourceRange = ActiveSheet.Range(Cells(1, 1), Cells(5, 1))
Set targetRange = ActiveSheet.Cells(6, 1)
sourceRange.Copy
targetRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End Sub
The Transpose function takes parameter of type Varaiant and returns Variant.
Sub transposeTest()
Dim transposedVariant As Variant
Dim sourceRowRange As Range
Dim sourceRowRangeVariant As Variant
Set sourceRowRange = Range("A1:H1") ' one row, eight columns
sourceRowRangeVariant = sourceRowRange.Value
transposedVariant = Application.Transpose(sourceRowRangeVariant)
Dim rangeFilledWithTransposedData As Range
Set rangeFilledWithTransposedData = Range("I1:I8") ' eight rows, one column
rangeFilledWithTransposedData.Value = transposedVariant
End Sub
I will try to explaine the purpose of 'calling transpose twice'.
If u have row data in Excel e.g. "a1:h1" then the Range("a1:h1").Value is a 2D Variant-Array with dimmensions 1 to 1, 1 to 8.
When u call Transpose(Range("a1:h1").Value) then u get transposed 2D Variant Array with dimensions 1 to 8, 1 to 1. And if u call Transpose(Transpose(Range("a1:h1").Value)) u get 1D Variant Array with dimension 1 to 8.
First Transpose changes row to column and second transpose changes the column back to row but with just one dimension.
If the source range would have more rows (columns) e.g. "a1:h3" then Transpose function just changes the dimensions like this: 1 to 3, 1 to 8 Transposes to 1 to 8, 1 to 3 and vice versa.
Hope i did not confuse u, my english is bad, sorry :-).
You do not need to do this. Here is how to create a co-variance method:
http://www.youtube.com/watch?v=RqAfC4JXd4A
Alternatively you can use statistical analysis package that Excel has.
Strictly in reference to prefacing "transpose", by the book, either one will work; i.e., application.transpose() OR worksheetfunction.transpose(), and by experience, if you really like typing, application.WorksheetFunction.Transpose() will work also-
Something like this should do it for you.
Sub CombineColumns1()
Dim xRng As Range
Dim i As Long, j As Integer
Dim xNextRow As Long
Dim xTxt As String
On Error Resume Next
With ActiveSheet
xTxt = .RangeSelection.Address
Set xRng = Application.InputBox("please select the data range", "Kutools for Excel", xTxt, , , , , 8)
If xRng Is Nothing Then Exit Sub
j = xRng.Columns(1).Column
For i = 4 To xRng.Columns.Count Step 3
'Need to recalculate the last row, as some of the final columns may not have data in all rows
xNextRow = .Cells(.Rows.Count, j).End(xlUp).Row + 1
.Range(xRng.Cells(1, i), xRng.Cells(xRng.Rows.Count, i + 2)).Copy .Cells(xNextRow, j)
.Range(xRng.Cells(1, i), xRng.Cells(xRng.Rows.Count, i + 2)).Clear
Next
End With
End Sub
You could do this too.
Sub TransposeFormulas()
Dim vFormulas As Variant
Dim oSel As Range
If TypeName(Selection) <> "Range" Then
MsgBox "Please select a range of cells first.", _
vbOKOnly + vbInformation, "Transpose formulas"
Exit Sub
End If
Set oSel = Selection
vFormulas = oSel.Formula
vFormulas = Application.WorksheetFunction.Transpose(vFormulas)
oSel.Offset(oSel.Rows.Count + 2).Resize(oSel.Columns.Count, oSel.Rows.Count).Formula = vFormulas
End Sub
See this for more info.
http://bettersolutions.com/vba/arrays/transposing.htm
if you just want to copy and transpose the values in the clipboard you can use the following makro:
Sub PasteVal()
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
End Sub
I have a worksheet which has many terms in Column A.I want to search for two terms for example
term A and term B and copy all rows between the two terms and paste it into a new sheet.These two terms may repeat in the column. The problem which I am basically facing the following problem : whenever I run my code it also copies rows between term B and term A which is unnecessary. Following is the code i am using for two terms term A and term B.
For example my column A is
Institute
Event
Job
Computer
Laptop
Figures
Event
figures
format
computer
and many more terms
I want to copy all the rows between term A: Event and term B: Laptop and paste it into a new sheet. What my code is doing is it is copying the rows between all combinations of Event and computer. Even the rows between computer and event are copied(in this case Figure and laptop).
Sub OpenHTMLpage_SearchIt()
Dim Cell As Range, Keyword$, N%, SearchAgain As VbMsgBoxResult
Dim ass As Variant
Dim Cellev As Range, prakash$, P%, SearchAgaina As VbMsgBoxResult
Dim asa As Variant
StartSearch:
N = 1
Keyword = "Event"
If Keyword = Empty Then GoTo StartSearch
For Each Cell In Range("A1:A500")
If Cell Like "*" & Keyword & "*" Then
ass = Cell.Address
P = 1
prakash = "Computer"
If prakash = Empty Then GoTo StartSearch
For Each Cellev In Range("A1:A500")
If Cellev Like "*" & prakash & "*" Then
asa = Cellev.Address
Range(asa, ass).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Range("B13").Select
ActiveSheet.Paste
Worksheets("sheet1").Select
P = P + 1
End If
Next Cellev
N = N + 1
End If
Next Cell
End Sub
Edit: code formatting.
The following is the code which is working for me.This copies everything in between Event and laptop and pastes it into a new sheet. Then again it searches for a second time and this time the search will start from the next row to the first search.I hope I am clear with this.
Sub Star123()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
rownum = 1
colnum = 1
lastrow = Worksheets("Startsheet").Range("A65536").End(xlUp).Row
With ActiveWorkbook.Worksheets("StartSheet").Range("a1:a" & lastrow)
For rownum = 1 To lastrow
Do
If .Cells(rownum, 1).Value = "Event" Then
startrow = rownum
End If
rownum = rownum + 1
If (rownum > lastrow) Then Exit For
Loop Until .Cells(rownum, 1).Value = "Laptop"
endrow = rownum
rownum = rownum + 1
Worksheets("StartSheet").Range(startrow & ":" & endrow).Copy
Sheets("Result").Select
Range("A1").Select
ActiveSheet.Paste
Next rownum
End With
End Sub
Try this:
Sub DoEeeeeet(sheetName, termA, termB)
Dim foundA As Range, _
foundB As Range
Dim newSht As Worksheet
With Sheets(sheetName).Columns(1)
Set foundA = .Find(termA)
If Not foundA Is Nothing Then
Set foundB = .Find(termB, after:=foundA, searchdirection:=xlPrevious)
End If
End With
If foundA Is Nothing Or foundB Is Nothing Then
MsgBox "Couldn't find " & IIf(foundA Is Nothing, termA, termB)
Else
Range(foundA, foundB).Copy
Set newSht = Sheets.Add
newSht.Range("B13").PasteSpecial
End If
End Sub
You can call it as follows:
DoEeeeeet "Sheet1","Event","Laptop"
It'll find the first instance of "Event" and the last instance of "Laptop" on the sheet named "Sheet1" and copy all of that data to B13 and subsequent cells in a new sheet.
Is that what you want? Or do you want each of the subranges beginning with "Event" and ending with "Laptop"?
What are some ways I can make this work I have been trying to figure it out for hours.
I have tried using Offset in the loop but I haven't got it to work
for example I used x = x.Offset(10,0) and i = i.Offset(5,0) etc.
Sub Macro5()
Dim i As Range, j As Range, k As Range
Dim x As Range, y As Range
Dim Num As Integer
Num = 94
Set x = Sheets("Sum Data").Range("B1:G10")
Set j = Sheets("PNA Physical Needs Summary Data").Range("C4:L9")
Set i = Sheets("PNA Physical Needs Summary Data").Range("B4:B9")
Set k = Sheets("Sum Data").Range("A1")
Set p = Sheets("PNA Physical Needs Summary Data").Range("P3:P8")
Set e = Sheets("PNA Physical Needs Summary Data").Range("A4:A9")
Do
x.Copy
j.Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
p.Copy i
k.Copy e
Num = Num - 1
Loop Until Num = 0
End Sub
I do not understand what you are trying to do but the current routine successfully copies data from one set of ranges to another.
Have you omitted the Set from the statements to update x and i? The following appear to work as you would expect
Set x = x.Offset(10,0)
Set i = i.Offset(5,0)
If omission of Set is not your problem, please expand your question to include your full code and the nature of the failure you experience.