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.
Related
I am currently trying to sort out data.
This is the given data. The list goes on and the numbers of 123 will vary.
Header Header
A 1 2 3 4 5
B 1 2 3 4 5 6 7
C 1 2
....
....
....
What it should look after being sort out
Header Header
A 1
A 2
A 3
A 4
A 5
B 1
B 2
B 3
B 4
B 5
B 6
B 7
C 1
C 2
I have tried doing the codes for this by using insert, copy and paste special. I am trying to work with a small number first to test out but it doesn't seem to work with the loop. Does anyone have any suggestions on how I can do this or what can improve on?
s = 3
x = 0
w = 2
For d = 0 To 1 Step 1
y = 3
x = 0
Do Until IsEmpty(Sheet1.Cells(w, y).Value)
y = y + 1
x = x + 1
Loop
Rows(s & ":" & v + 2).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
z = x + 2
Set ran = Sheet1.Range(Sheet1.Cells(w, s), Sheet1.Cells(w, z))
ran.Copy
Sheet1.Range(Sheet1.Cells(s, w), Sheet1.Cells(s, w)).PasteSpecial
Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
ran.Clear
w = w + v + 1
s = s + v
Next d
It took so many time but here we go,
Sub mertinc()
Dim mert, inc As Long
Application.ScreenUpdating = False
Range("a1048576").Select
mert = Selection.End(xlUp).Row
Dim mertindex As Integer
mertindex = 1
Do While mertindex <= mert
Range("a" & mertindex).Activate
inc = Range(Selection.Offset(0, 1), Selection.End(xlToRight)).Count
Range(Selection.Offset(0, 1), Selection.End(xlToRight)).Copy
Range("XX1048576").Select
Selection.End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Range("XW1048576").Select
Selection.End(xlUp).Offset(1, 0).Resize(inc, 1).Select
Selection.Value = Range("a" & mertindex).Value
mertindex = mertindex + 1
Loop
Application.ScreenUpdating = True
End Sub
In this example, you can get exactly what you want in the XW and XX columns. You can create another page to create this list over there, or you can clear your previous list and copy new one instead of them. That's up to you now.
If you don't understand any part of the code, let me know.
This is just to see how we can improve Mertinc's code to follow best practices with some minor improvements.
This is expressly not to blame anyone but good for learning purpose and seeing the differences.
Option Explicit
Sub TransformData()
Dim lastRowScr As Long, lastRowDest As Long
Dim numCols As Long
Dim wsSrc As Worksheet, wsDest As Worksheet
Set wsSrc = ThisWorkbook.Worksheets("Sheet1") '* worksheet with source data
Set wsDest = ThisWorkbook.Worksheets("Sheet2") '* another worksheet to paste data
Application.ScreenUpdating = False
lastRowScr = wsSrc.Range("A" & wsSrc.Rows.Count).End(xlUp).Row '* determine last row in column A
Dim iRow As Long
iRow = 1
Do While iRow <= lastRowScr
With wsSrc.Range(wsSrc.Range("B" & iRow), wsSrc.Range("A" & iRow).End(xlToRight))
numCols = .Count
.Copy
End With
With wsDest
lastRowDest = .Range("B" & .Rows.Count).End(xlUp).Row
If IsEmpty(.Range("B" & lastRowDest)) Then lastRowDest = lastRowDest - 1 '* make sure that we start in row 1
.Range("B" & lastRowDest + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
.Range("A" & lastRowDest + 1).Resize(numCols, 1).Value = wsSrc.Range("A" & iRow).Value
End With
iRow = iRow + 1
Loop
Application.ScreenUpdating = True
End Sub
This procedure uses sheet1 as data source and inserts the transformed data into sheet2.
Explanations
Here I try to explain the differences and show some further literature.
1. Always use descriptive variable and procedure/function naming
Using your username for naming procedures and variables
Sub mertinc()
Dim mert, inc As Long
is bad practice instead you should use descriptive names like
Sub TransformData()
Dim lastRowScr As Long, lastRowDest As Long
Dim numCols As Long
also every variable needs to be specified with a type. Dim mert, inc As Long will leave mert as variant and only declares inc as long.
Much better readability for yourself and other persons and therefore probably less issues in your codes.
2. Always use long instead of integer
Never use integer unless you need to interop with an old API call that expects a 16 bit int. There is no advantage using integer instead of long.
3. Avoid using Select or Activate
Instead of using .Select or .Activate
Range("a1048576").Select
lastRowScr = Selection.End(xlUp).Row
use a direct access
lastRowScr = Range("a1048576").End(xlUp).Row
Much faster and shorter code.
4. Also never assume the worksheet
Always use full qualified ranges
Set ws = ThisWorkbook.Worksheets("Sheet1")
lastRowScr = ws.Range("a1048576").End(xlUp).Row
Less issues. If another sheet was selected, this code still works.
5. Never use fixed row counts
Instead of fixed row counts
lastRowScr = ws.Range("a1048576").End(xlUp).Row
always detect the last row
lastRowScr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Different Excel versions have different max. row counts. Therefore this code runs version independent.
I'm currently trying to normalize data with VBA in Excel. Therefore, my workbook imports several csv files and wrote them in different worksheets all of them are built like this.
First row: Header
First column: x-Axis (for plotting)
Second column to nth column: y-values
Now I want to normalize all columns from 2 to n (dividing by maximum value of each column). Here is the function I'm using so far:
Sub NormalizeData(dataName)
cs = Worksheets(dataName).UsedRange.SpecialCells(xlCellTypeLastCell).Column
rs = Worksheets(dataName).UsedRange.SpecialCells(xlCellTypeLastCell).Row
For col = 2 To cs
maxValue = Application.WorksheetFunction.Max(Worksheets(dataName).Columns(col))
For r = 2 To rs
Worksheets(dataName).Cells(r, col) = Worksheets(dataName).Cells(r, col) / maxValue
Next r
Next col
End Sub
This approach works, but because of the amount of data, it's very slow. Is there any way to increase the speed? I already switched of the screen update.
Thanks you very much for your help!!!
Use another sheet and PasteSpecial.
Assuming ws1 contains your data and ws2 is currently unused:
with ws2.Range(.Cells(2,2), .Cells(rs, cs))
.value = maxValue
.copy
end with
ws1.Range(.Cells(2,2), .Cells(rs, cs)).PasteSpecial _
Operation:=xlPasteSpecialOperationDivide
Application.CutCopyMode = False
Here is a sub that normalizes the numbers in a rectangular range. You can decide on what range you want to normalize and then pass that range to this sub:
Sub NormalizeRange(R As Range)
'assumes that R is a rectangular range
'will throw an error if any column has max 0
Dim vals As Variant, maxes As Variant
Dim i As Long, j As Long, m As Long, n As Long
m = R.Rows.Count
n = R.Columns.Count
ReDim maxes(1 To n)
With Application.WorksheetFunction
For i = 1 To n
maxes(i) = .Max(R.Columns(i))
Next i
End With
vals = R.Value
For i = 1 To m
For j = 1 To n
vals(i, j) = vals(i, j) / maxes(j)
Next j
Next i
R.Value = vals
End Sub
This will be more efficient than what you currently has since it moves values between the spreadsheet and VBA in bulk transfers rather than via a large number of individual read/writes. It also avoids things like screen-updating issues and intermediate recalculation of functions depending on these values.
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
my code is running really slowly and I'm trying to fasten it. The only way I can think of is to do without the last bit of code which does copy, select,paste twice for two different target worksheets. Was wondering if I'm able to change it to something like Destination:= ____ & ____ instead of selecting and pasting twice?
Sub compare()
'compare if the values of two ranges are the same
'Select workbook to prevent mismatch error
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Workbooks("Compare.xlsm").Activate
Dim referencesheetname, newsheetname, outputsheetname As String
referencesheetname = "Reference"
newsheetname = "New"
Dim range1, range2 As Range
'define the variables
Dim referencesheetcols As Integer
Dim range1rows, range1cols, range2rows, range2cols, testrows, testcols, i, j, p, q As Long
Dim bMatches, rowmatched As Boolean
Dim product As String
'Define names for easy reference
product = "Ethylene"
'Set range you wish the macro to search up till
newsheetcols = 3000
referencesheetcols = 3000
'How many rows and columns should we compare?
'Set testcols to 150 to test whole range
testrows = 1
testcols = 200
'Set p for position to place data at (i.e. if p=1, data will be pasted)
p = Sheets(referencesheetname).UsedRange.Rows.Count
q = Sheets("Datasheet").UsedRange.Rows.Count
'Pasted table range data starts from row 7
For l = 1 To newsheetcols
'ActiveWorkbook.Worksheets(newsheetname).Select
'only test if correct product down column B
If CStr(Sheets(newsheetname).Rows(l).Cells(1, 2).Value) = product Then
rowmatched = False
For k = 5 To referencesheetcols
'bmatch = False
'Define range compare rows 6 onwards for both sheets
Set range1 = Sheets(referencesheetname).Rows(k)
Set range2 = Sheets(newsheetname).Rows(l)
' count the rows and columns in each of the ranges
range1rows = range1.Rows.Count
range1cols = range1.Columns.Count
range2rows = range2.Rows.Count
range2cols = range2.Columns.Count
'Check if ranges are the same dimension?
bMatches = (range1rows = range2rows And range1cols = range2cols)
'if same dimensions loop through the cells
If bMatches Then
For i = 1 To testrows
For j = 1 To testcols
If (range1.Cells(i, j).Value <> range2.Cells(i, j).Value) Then
'Conclude that range dimension is not the same
bMatches = False
i = testrows
j = testcols
'Exit loops
End If
Next
Next
End If
'If ranges of two comparison sheets are the same
If bMatches Then
rowmatched = True
k = referencesheetcols
End If
'Sheets(outputsheetname).Cells(1, 1).Value = rowmatched
'Set place to paste data
If (Not (rowmatched) And k = referencesheetcols) Then
'Copy and paste specified number of columns
range2.Resize(1, 300).Copy
Sheets(referencesheetname).Cells(p, 1).Offset(2, 0).Select
ActiveSheet.Paste
p = p + 1
Sheets("Datasheet").Activate
ActiveSheet.Cells(q, 1).Offset(2, 1).Select
ActiveSheet.Paste
q = q + 1
End If
Next
End If
Next
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
Something like below should be ok to change to copy - destination.
range2.Resize(1, 300).Copy Destination:=Sheets(referencesheetname).Cells(p, 1).Offset(2, 0)
Although if you really wanted to speed up your code I would say you would need to read the range into an array and then do your processing on the array. looking at the sheet is costly in terms of cpu time, selecting should be avoided where ever possible
You could also turn calculation off and just recalc when you need it too. You could also look up "WITH"'s as these can speed it up a bit too
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