I have a set of values in range L10:M34 and I'd like to select all L:M where M doesn't have value 0. Then I want to paste whole selection as values without blacks to U5. I am able to do that manually, but I'd like to use VBA, and repeat this to 2 other sets of locations in same worksheet.
What I have is only selecting whole range to copy, and I'd like to exclude rows where M has 0.
Range("L10:M34").Select
Selection.Copy
Range("U5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
If I understand you correctly :
Sub test()
Dim rg As Range: Dim dest As Range
Dim i As Long: Dim col As Long
Dim rgNonZero As Range: Dim r As Range
Set rg = Range("L10:M34")
i = Range(Split(rg.Address(0, 0), ":")(0)).Row
col = Range(Split(rg.Address(0, 0), ":")(1)).Column
Do Until Cells(i, col) <> 0: i = i + 1: Loop
Set rgNonZero = Range(Cells(i, col - 1), Cells(i, col))
For Each r In rg.Rows
If r.Columns(2).Value <> 0 Then Set rgNonZero = Union(rgNonZero, r)
Next
rgNonZero.Copy
Range("U5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
End Sub
First the sub create the data range in L10:M34 as rg variable.
Then get the first row defined in rg into i variable.
Then get the column (which has the zero and non zero values) number into col variable.
Then it loop (sorry difficult for me to explain in English) until it find the first row of column M which has value non-zero, then set the range of this row as rgNonZero variable.
Then it loop each row in rg as r variable, and check if this row column(2) value is not zero - then it add the range of r into rgNonZero.
After the loop done, it copy rgNonZero and paste tranpose to cell U5.
Related
Basically I just need excel to verify if Cell A1 is empty.
If A1 is empty, paste starting in A1.
If A1 is not empty, go down to the next blank cell in Column A, and paste there.
I am receiving an error : Application-defined or object-defined error on the Else part of the code.
If IsEmpty("A1") Then
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else
Range("A1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
I noticed two issues. (1) In the first line of code, you are testing whether the text "A1" is empty, not cell A1. So first change it so that the IsEmpty tests the cell A1. (2) As you add entries below A1, you need some method of counting how many rows down to go before pasting. Right now, your code starts at cell A1 and offsets by 1. This will only work once. The sample below counts how many rows are filled in the A column and then offsets by 1 row.
If IsEmpty(Range("A1")) Then
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Paste into Next Available Cell in Column
The Issues
Look at your code and imagine that cell A1 is not empty, but the rest of the cells in column A are. Then Range("A1").End(xlDown) will 'jump' to the bottom-most cell of column A: A1048576. You are additionally trying to do .Offset(1) which is not possible, hence the error.
Now again, look at your code and imagine that the range A1:A5 is not empty, but cell A6 is. Then Range("A1").End(xlDown).Offset(1, 0) will 'jump' to cell A6. But imagine that cell A7 is also not empty. Then you will possibly overwrite the value in cell A7.
Introducing a Function (A Quick Fix)
You could do:
Dim dCell As Range: Set dCell = RefFirstAvailableCell(Range("A1"))
dCell.PasteSpecial Paste:=xlPasteValues ' the rest were default values
Application.CutCopyMode = False
which uses the following function:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the First Available Cell in a column,
' i.e. creates a reference to the cell
' below the Last Non-Empty Cell in the Column Range
' spanning from the First Cell of a range ('rg')
' to the Bottom-Most Cell of the worksheet column.
' Remarks: If all cells in the Column Range are empty,
' it creates a reference to the First Cell.
' If the Bottom-Most Cell of the worksheet column
' is not empty, it returns 'Nothing'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefFirstAvailableCell( _
ByVal rg As Range) _
As Range
If rg Is Nothing Then Exit Function
With rg.Cells(1)
Dim wsrCount As Long: wsrCount = .Worksheet.Rows.Count
Dim fRow As Long: fRow = .Row
Dim lCell As Range
Set lCell = .Resize(wsrCount - fRow + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then
Set RefFirstAvailableCell = .Offset
Else
Dim lRow As Long: lRow = lCell.Row
If lRow = wsrCount Then
Exit Function
Else
Set RefFirstAvailableCell = .Offset(lRow - fRow + 1)
End If
End If
End With
End Function
Testing the Function
Instead of the End statement, the function uses the Range.Find method, which is more reliable. In fact, it 'normally' (think merged cells or similar) only fails if the worksheet is filtered.
The following procedure illustrates how to copy by assignment, which is 'cleaner' and more efficient (faster) than PasteSpecial when copying values only. It also introduces some additional fail-safes (Validate...).
To utilize it, copy both codes to a standard module (e.g. Module1) of a new workbook and make sure it contains Sheet1 and Sheet2 (code names). Run the procedure and see what has happened in both worksheets. Repeat the steps a few times and observe the changes in Sheet1. Play with it by changing the various constant values in this procedure's code (not the function).
Sub RefFirstAvailableCellTEST()
' Create a reference to the Source Range.
Dim srg As Range: Set srg = Sheet2.Range("B2:D5")
' Populate the Source Range.
Dim sCell As Range
Dim n As Long
For Each sCell In srg.Areas(1).Cells
n = n + 1
sCell.Value = n
Next sCell
' Write the number of source rows and columns to variables.
Dim rCount As Long: rCount = srg.Rows.Count
Dim cCount As Long: cCount = srg.Columns.Count
' Create a reference to the Destination Initial First Cell.
Dim diCell As Range: Set diCell = Sheet1.Range("A2")
' Create a reference to the Destination First Available Cell.
Dim dCell As Range: Set dCell = RefFirstAvailableCell(diCell)
' Validate First Available Cell.
If dCell Is Nothing Then Exit Sub
If dCell.Row > Sheet1.Rows.Count - rCount + 1 Then Exit Sub
If dCell.Column > Sheet1.Columns.Count - cCount + 1 Then Exit Sub
' Create a reference to the Destination Range.
Dim drg As Range: Set drg = dCell.Resize(rCount, cCount)
' Write the values from the Source Range to the Destination Range.
drg.Value = srg.Value
End Sub
I am looking to create a macro which would allow me to copy and paste data from one column and then transpose that data over 2 columns in the right order
I have recorded a macro while doing the process manually
Range("G3").Select
Application.CutCopyMode = False
Selection.Copy
Range("G2:G7").Select ' (The column range I want to copy)
Application.CutCopyMode = False
Selection.Copy
Range("I1").Select ' (Row where the range of G2:G7) is now transposed)
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("H2:H7").Select ' (The second column range I want to copy)
Application.CutCopyMode = False
Selection.Copy
Range("I2").Select ' (Second Row where the range of H2:H7) is now transposed)
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("H8:H13").Select ' (The third column range I want to copy)
Application.CutCopyMode = FalseSelection.Copy
Range("I3").Select' ( Third Row where the range of H8:H13) is now transposed)
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
The problem is that this code only works up to certain number of rows (up till H13 for example), but if I want to this repeat this process up to row H600 (range of H600:H605) and pasting to I31 for example without copying and pasting this code hundreds of times, is there a way I can do this?
This is what I mean by example
Column H
Star
Greenwood
Titon
Humford
converted to
Column I | Column J**
Star | Greenwood
titon | Humford
Here's an alternative to Copy/Paste - using Variant Arrays. This will be much faster for large data sets.
Sub Demo()
Dim rng As Range
Dim Src As Variant
Dim Dst As Variant
Dim GroupSize As Long
Dim Groups As Long
Dim iRow As Long
Dim iCol As Long
Dim iDst As Long
Dim SrcStartRow As Long
Dim SrcColumn As Long
Dim DstStartRow As Long
Dim DstColumn As Long
' Set up Parameters
GroupSize = 2
SrcStartRow = 2
SrcColumn = 8 'H
DstStartRow = 1
DstColumn = 9 'I
With ActiveSheet 'or specify a specific sheet
' Get Reference to source data
Set rng = .Range(.Cells(SrcStartRow, SrcColumn), .Cells(.Rows.Count, SrcColumn).End(xlUp))
' Account for possibility there is uneven amount of data
Groups = Application.RoundUp(rng.Rows.Count / GroupSize, 0)
If rng.Rows.Count <> Groups * GroupSize Then
Set rng = rng.Resize(Groups * GroupSize, 1)
End If
'Copy data to Variant Array
Src = rng.Value2
'Size the Destination Array
ReDim Dst(1 To UBound(Src, 1) / GroupSize, 1 To GroupSize)
'Loop the Source data and split into Destination Array
iDst = 0
For iRow = 1 To UBound(Src, 1) Step GroupSize
iDst = iDst + 1
For iCol = 1 To GroupSize
Dst(iDst, iCol) = Src(iRow + iCol - 1, 1)
Next
Next
' Move result to sheet
.Cells(DstStartRow, DstColumn).Resize(UBound(Dst, 1), UBound(Dst, 2)).Value = Dst
End With
End Sub
Before
Well, you are not really transposing, but I would use this method. I start at 2 to leave the first in place, then basically move the next one over and delete all the empty spaces at the end.
Sub MakeTwoColumns()
Dim x As Long
For x = 2 To 500 Step 2
Cells(x, 6) = Cells(x, 5)
Cells(x, 5).ClearContents
Next x
Columns(5).SpecialCells(xlCellTypeBlanks).Delete
Columns(6).SpecialCells(xlCellTypeBlanks).Delete
End Sub
After
I have 135 rows of data in columns A to U
I am trying to write a script that will help me copy each column of data one under another to a clean worksheet.
Right now i wrote some code that will do it for the first two columns and i would prefer to have it done more automatically/dynamically instead of me copy pasting these two code blocks and altering the ranges
Range("A764:A897").Select
Selection.Copy
Sheets("New").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Sheets("Rom").Select
Range("B764:B897").Select 'id like to have this increment automaticaly
Selection.Copy
Sheets("New").Select
Range("A135").Select 'id like to have this increment automaticaly
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Try this. Adjust sheet name as necessary.
You can speed up the operation by directly transferring values rather then copying and pasting.
You could define the 134 as a constant so you only have to change once in the code rather than three times.
Sub x()
Dim rCopy As Range
Dim r As Long: r = 1
Set rCopy = Sheets("Name of source sheet").Range("A764").Resize(134) 'adjust sheet name
Do Until IsEmpty(rCopy(1))
Sheets("New").Cells(r, 1).Resize(134).Value = rCopy.Value
Set rCopy = rCopy.Offset(, 1)
r = r + 134
Loop
End Sub
Supposing your data in sheet “Rom” start at row 764:
Sub test()
Dim ws1, ws2 as string
Dim i, lr, lc as long
ws1 = “Rom”
ws2 = “New”
lc = sheets(ws1).cells(764,columns.count).end(xltoleft).column
For i = 1 to lc
lr = sheets(ws2).cells(Rows.count,1).End(xlUp).row + 1
sheets(ws1).range(cells(i, 764),cells(i,897)).Select
Selection.Copy
Sheets(ws2).cells(lr,1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Next
End sub
You can read in each column of data to an array and then paste it into your new column. In this way, you can perform any mutations needed on the data.
If you have 135 rows (always)
Dim ws As Worksheet, arr As Variant, myRange As Range, i As Integer, col As Integer, k As Integer
Set ws = ThisWorkbook.Sheets("Sheet1") ' or whatever your worksheet is
ReDim arr(1 To 135*22) ' 22 letters from A To U
k = 1
With ws
For col = 1 To 22
For i = 764 To 897
arr(k) = .Cells(col, i).Value2 ' if you need to do anything else here
k = k+1
Next i
Next col
End with
Set ws = ThisWorkbook.Sheets("New") 'or wherever this is going
With ws
.Range("A1").Resize(UBound(arr), 1).Value = Application.Transpose(arr)
End with
I have created the following macro
I have data going all the way to row 3710 in the master data sheet - and I do not know how to force this macro to loop and include all the data
Sub Macro3()
'
' Macro3 Macro
'
'
Range("A1:A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1:B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Sheet1").Select
Range("A3:A4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("A2:B2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
You can do this with a for loop. Also Copy/Paste is something we generally shy away from in VBA as well as .SELECT and .ACtivate. Those are functions that a human performs, but the computer can just set cells equal to other cell's values like:
Sheets("Sheet1").Cells(1, 1).value = Sheets("Sheet2").Cells(1,1).value
Which says Cell "A1" in Sheet1 should be set to whatever the value is in Sheet2 Cell "A1".
Changing things around, implementing a loop to perform your transpose, and using some quick linear regression formula to determine which row to write to we get:
Sub wierdTranspose()
'Loop from row 1 to row 3710, but every other row
For i = 1 to 3710 Step 2
'Now we select from row i and row i + 1 (A1 and A2, then A3 and A4, etc)
'And we put that value in the row of sheet2 that corresponds to (.5*i)+.5
' So if we are picking up from Rows 7 and 8, "i" will be 7 and (.5*i)+.5 will be row 4 that we paste to
' Then the next iteration will be row 9 and 10, so "i" will be 9 and (.5*i)+.5 will be row 5 that we paste to
' and on and on until we hit 3709 and 3710...
Sheets("Sheet2").Cells((.5*i)+.5, 1).value = Sheets("Sheet1").Cells(i, 1).value
Sheets("Sheet2").Cells((.5*i)+.5, 2).value = Sheets("Sheet1").Cells(i+1, 1).value
Next i
End Sub
Bulk data is best transferred via VBA arrays, with no copy/paste required.
Something like this:
Sub SplitColumn()
Dim A As Variant, B As Variant
Dim i As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
With ws1
A = .Range(.Cells(1, 1), .Cells(3710, 1))
End With
ReDim B(1 To 1855, 1 To 2)
For i = 1 To 1855
B(i, 1) = A(2 * i - 1, 1)
B(i, 2) = A(2 * i, 1)
Next i
With ws2
.Range(.Cells(1, 1), .Cells(1855, 2)).Value = B
End With
End Sub
I am a bad VBA person. Please help me.
I want to relocate three values in a single column and put them in a single row using Offset. I need to flatten 3 rows of data into a single row of data.
Here is the code - it's very crude:
Sub Macro1()
'
' Macro1 Macro
'
'turn off display update
Application.ScreenUpdating = False
Dim CVFESUMMARY2(2000, 2000)
Dim MAXROW As Integer
Dim i As Integer
Dim r As Range
Dim x As Range
Dim y As Range
Dim z As Range
Set r = Range("BJ13:BJ512")
Set x = Range("BK13:BK512")
Set y = Range("BL13:BL512")
Set z = Range("BM13:BM512")
MAXROW = 300
'format "new" columns
Range("BK11").Select
ActiveCell.FormulaR1C1 = "NORM"
Range("BL11").Select
ActiveCell.FormulaR1C1 = "MIN"
Range("BM11").Select
ActiveCell.FormulaR1C1 = "MAX"
Columns("BJ:BM").Select
Selection.ColumnWidth = 12
'define the "COPY DATA FROM" starting cell location
Sheets("CVFESUMMARY2").Select
Range("BJ13").Select
'cycle through all of the rows in range r
For i = 1 To MAXROW
'copy "BJ13"
r.Select
Selection.Copy
'paste "value only" in column "BK13"
x.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'copy "BJ13+1"
Set r = r.Offset(1, 0)
r.Select
Selection.Copy
'paste "value only" in column "BL13"
y.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'copy "BJ13+2"
Set r = r.Offset(1, 0)
r.Select
Selection.Copy
'paste "value only" in column "BM13"
z.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'move active cell to "BJ13+4"
Set r = r.Offset(2, 0)
Set x = x.Offset(4, 0)
Set y = y.Offset(4, 0)
Set z = z.Offset(4, 0)
Next i
'turn on display update
Application.ScreenUpdating = True
End Sub
This somewhat works but it is adding values in rows +2 and +3 that I don't want; I think the looping is wrong. Thanks in advance!
Before
After
Your desired output, can the results be compacted? (all empty rows removed, leaving a block of data) or is there information in the columns before that its linked with?
Removing the extra rows wouldn't be much extra work.
With the following code (which I think does what you want) the MaxRows value is incorrect. The way it works this should be a MaxRecords ie: the number of groups of data you.
Sub Transpose()
Dim Position As Range
Dim Source As Range
Dim MaxRow As Integer
Dim Index As Integer
' set column titles
Range("BK11").Value2 = "NORM"
Range("BL11").Value2 = "MIN"
Range("BM11").Value2 = "MAX"
' set the width
Range("BJ:BM").ColumnWidth = 12
MaxRow = 512 ' see note below
Set Position = Range("BJ13") ' define the start position
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'For Index = 1 To MaxRow
Do
' create a range that contains your first 3 values
Set Source = Range(Position, Position.Offset(RowOffset:=2))
' copy it
Source.Copy
' paste and transpose the values into the offset position
Position.Offset(ColumnOffset:=1).PasteSpecial xlPasteValues, SkipBlanks:=False, Transpose:=True
' OPTIONAL - Clear the contents of your source range
Source.ClearContents
' re-set the position ready for the next iteration
Set Position = Position.Offset(RowOffset:=4)
'Next
Loop While Position.Row < RowMax
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Note: I've not used Select and Selection as they confuse me! Using Range() makes it simpler to know where you are imo.
Update I've included one that also compacts the output
Sub TransposeCompact()
Dim Position As Range
Dim Source As Range
Dim Destination As Range
Dim MaxRow As Integer
Dim Index As Integer
' set column titles
Range("BK11").Value2 = "NORM"
Range("BL11").Value2 = "MIN"
Range("BM11").Value2 = "MAX"
' set the width
Range("BJ:BM").ColumnWidth = 12
MaxRow = 512 ' see note below
' define the start position
Set Position = Range("BJ13")
' define the first output position
Set Destination = Position.Offset(ColumnOffset:=1)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'For Index = 1 To MaxRow
Do
' create a range that contains your first 3 values
Set Source = Range(Position, Position.Offset(RowOffset:=2))
' copy it
Source.Copy
' paste and transpose the values into the offset position
Destination.PasteSpecial xlPasteValues, SkipBlanks:=False, Transpose:=True
' OPTIONAL - Clear the contents of your source range
Source.ClearContents
' re-set the position ready for the next iteration
Set Position = Position.Offset(RowOffset:=4)
' increment the row on the output for the next iteration
Set Destination = Destination.Offset(RowOffset:=1)
'Next
Loop While Position.Row < RowMax
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Update 2
Your i variable used in the For Loop is not actually used, if your data is in rows 13 to 512 then the edits I've made to the code above should help.
The RowMax variable now will stop the macro when Position.Row goes beyond it.