I am trying to transpose every next two cells and paste them in next right cells.
I have a table as shown in the screenshot:
I want to copy range "B2:B3" and transpose this to "C2" and then loop until there is some data in column B. (so select and copy next "B4:B5" and transpose this to "B4").
I cannot get this to transpose in the right place and then loop.
I have something like this (I did not add loop yet to this macro):
Sub Macro1()
Dim a As Long, b As Long
a = ActiveCell.Column
b = ActiveCell.Row
Range("B2").Select
Range(ActiveCell, Cells(b + 1, a)).Select
Selection.Copy
End Sub
a VBA solution
Option Explicit
Sub main()
Dim pasteRng As Range
Dim i As Long
With ActiveSheet
Set pasteRng = .Range("C1:D2")
With .Range("B2:B" & .Cells(.Rows.count, "B").End(xlUp).Row)
For i = 1 To .Rows.count Step 2
pasteRng.Offset(i).Value = Application.Transpose(.Cells(i, 1).Resize(2))
Next i
End With
End With
End Sub
No VBA is needed. In C2 enter:
=INDEX(B:B,ROUNDUP(ROWS($1:1)/2,0)*2)
and copy down and in D2 enter:
=INDEX(B:B,ROUNDUP(ROWS($1:1)/2,0)*2+1)
and copy down:
and if you need this as part of some VBA effort:
Sub dural()
Dim i As Long
Dim r1 As Range, r2 As Range
For i = 2 To 10 Step 2
Set r1 = Range("B" & i & ":B" & (i + 1))
Set r2 = Range("C" & i)
r1.Copy
r2.PasteSpecial Transpose:=True
r2.Offset(1, 0).PasteSpecial Transpose:=True
Next i
End Sub
Related
i can copy whole rows but finding it difficult to locate the end cell of the row N and then copy everything from N2 to last the row. The end of the row - N ( cell) changes in length as the data imported changes
Sub Copy_To_Lastrow()
Application.ScreenUpdating = False
Dim Lastrow As Long
Sheets("Meeting1").Select
Range("N2").Select
Lastrow = Cells(Rows.Count, "AN").End(xlUp) + 1
Range("n2").Copy Cells(Lastrow, "AN")
'Lastrow = Cells(Rows.Count, "AN").End(xlUp).Row + 1
'Range("n2").Copy Cells(Lastrow, "AE")
'Lastrow.PasteSpecial xlPasteValues
Range(Lastrow).PasteSpecial.Values
Application.ScreenUpdating = True
End Sub
One way, avoiding any copy/paste:
Sub Copy_To_Lastrow()
Dim lr As Long
With Worksheets("Meeting1") '<<should specify a workbook here...
lr = .Cells(.Rows.Count, "AN").End(xlUp).Row
.Range("N2:N" & lr).Value = .Range("N2").Value
End With
End Sub
I need to copy data from the 8th row into another sheet(sheet 2). I only need to copy every other cell, it should copy cell C8(first cell where the value is), E8, G8, I8 and so on from all the upto cell IK8.
Is there any way to do this? I have tried the step function in the for loop but its not working and only selecting one cell.It only pastes one value for cells H2:H130.
Sub Workplace()
Dim rng As Range
Dim LastRow As Long
Dim I As Long
LastRow = Worksheets("Questions").Range("C" & Rows.Count).End(xlUp).Row
For I = 8 To LastRow Step 3
Set rng = Worksheets("Questions").Range("C" & I)
rng.Copy
Next I
Worksheets("Sheet1").Range("H2:H130").PasteSpecial Transpose:=True
End Sub
You need to increment the column, not the row.
And move the paste inside the loop, though you need to increment the destination cell.
For i = 3 to 245 Step 2 ' column C to column IK
Set rng = Worksheets("Questions").Cells(8, i)
With Worksheets("Sheet1")
Dim dest as Range
Set dest = .Range("H" & .Rows.Count).End(xlUp).Offset(1)
End With
rng.copy Destination:=dest
Next
Or better, just use Union to build up a range to copy and then copy in one step:
For i = 3 to 245 Step 2 ' column C to column IK
If rng Is Nothing Then
Set rng = Worksheets("Questions").Cells(8, i)
Else
Set rng = Union(rng, Worksheets("Questions").Cells(8, i))
End If
Next
rng.Copy
Worksheets("Sheet1").Range("H2").PasteSpecial Transpose:=True
Application.CutCopyMode = False
EDIT:
"Is there a way to paste it in the first empty cell for Row H in sheet 1 instead of giving it a range?"
Yes, like the following:
Worksheets("Sheet1").Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Transpose:=True
I have two worksheets in one Excel workbook, and I only want to take the lines that have data in the cell (from worksheet1 into worksheet2) if Column A has data in it. My formula in worksheet 2 is =IF('Raw Data'!A2<>"", 'Raw Data'!A2,), but I actually don't want it to bring in the row at all if there is no data as shown in Rows 3 and 5. Right now it is bringing the whole row in:
In
you see that it is still bringing the row into worksheet 2 if there is no data. Any ideas how to only bring in the rows with the data?
Sub DataInCell()
Dim rw As Long
rw = 2
' Select initial sheet to copy from
Sheets("Raw Data").Select
' Find the last row of data - xlUp will check from the bottom of the spreadsheet up.
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' For loop through each row
For x = 2 To FinalRow
If Cells(x, 1).Value <> 0 Then
Range("A" & x & ":C" & x).Copy
Sheets("Sheet1").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 'Continue incrementing through the rows.
Cells(NextRow, 1).Select ' Find the next row.
ActiveSheet.Cells(NextRow, "A").PasteSpecial xlPasteAll ' Paste information.
Sheets("Raw Data").Select 'Reselect sheet to copy from. Probably uneccessary.
End If
Next x
End Sub
After you update the sheet names on the 3rd and 4th line, you will see that the code carries over the entire row. You can modify using Range(Cells, Cells) if you want partial ranges.
Option Explicit
Sub Non_Blanks()
Dim ms As Worksheet: Set ms = ThisWorkbook.Sheets("Sheet1") '<-- Master Sheet
Dim ns As Worksheet: Set ns = ThisWorkbook.Sheets("Sheet2") '<-- New Sheet
Dim i As Long, MoveMe As Range, LR As Long
For i = 2 To ms.Range("B" & ms.Rows.Count).End(xlUp).Row
If ms.Range("A" & i) = "*" Then
If Not MoveMe Is Nothing Then
Set MoveMe = Union(MoveMe, ms.Range("A" & i))
Else
Set MoveMe = ms.Range("A" & i)
End If
End If
Next i
If Not MoveMe Is Nothing Then
LR = ns.Range("A" & ns.Rows.Count).End(xlUp).Offset(1).Row
MoveMe.EntireRow.Copy
ns.Range("A" & LR).PasteSpecial xlPasteValuesAndNumberFormats
End If
End Sub
I currently have this code:
Sub createSheets(range_Copy As Range, range_Paste As Range)
'Copy the data
range_Copy.Copy
'Paste the data into the new worksheet
With range_Paste
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
End Sub
...and this...
Call createSheets(Sheets("Export from QB - Annual Sales").Range("E:T"), Sheets("Sales - " & Sales_Date_Annual).Range("A1"))
It works great but what I actually want to do is... when copying the range E:T, I only want to copy the rows that do not have a blank value in column E... regardless if there is anything in the other columns.
I think below code will help you. Useful information here is, that you can reference a cell in a range using relative reference, i.e. Range("D4:E6").Cells(1, 1) is reference to cell D4. This way you can easily loop through given range.
Sub LoppthroughRange()
Dim i As Long, j As Long, rng As Range
Set rng = Range("E:T")
For i = 1 To rng.Rows.Count
If Not IsEmpty(rng.Cells(i, 1)) Then
For j = 1 To rng.Columns.Count
'copy all cells in a row
Next
End If
Next
End Sub
Putting it all together, you should use:
Sub createSheets(range_Copy As Range, range_Paste As Range)
Dim i As Long, j As Long, k As Long
k = 1
For i = 1 To range_Copy.Rows.Count
If Not IsEmpty(range_Copy.Cells(i, 1)) Then
With range_Copy
.Range(Cells(i, 1), Cells(i, .Columns.Count)).Copy
End With
With range_Paste
.Range(Cells(k, 1), Cells(k, .Columns.Count)).PasteSpecial xlValues
.Range(Cells(k, 1), Cells(k, .Columns.Count)).PasteSpecial xlFormats
End With
k = k + 1
End If
Next
End Sub
I have two columns A and B with numbers as values.
In C1 I want =A1 + B1
In C2 I want =A2 + B2
and so on. I have written the following VBA code - while it works it adds "0" after the end of the last row in range.
Let's assume my last row is A10. It adds "0" in C11 when I run the code.
How do I prevent this?
Sub macro()
Dim R As Long
R = 1
Do
Cells(R, "C").Select
R = R + 1
ActiveCell.Formula = "=sum(" & ActiveCell.Offset(0, -2) & "," &
ActiveCell.Offset(0, -1) & ")"
Loop Until IsEmpty(ActiveCell.Offset(0, -2))
End Sub
Just replace your Until condition to the following string:
Loop Until IsEmpty(ActiveCell.Offset(1, -2))
That will check the right cell for being empty. The rest of your code should remain intact.
Take a look at Do Until and Do While and While.
If you really want to iterate over cells you may go ahead. But here a method using Arrays, this will by all means reduces any performance drops that you would get looping over cells...
Option Explicit
Sub AddToRigh()
Dim i As Integer
Dim vArr As Variant
Dim LastRow As Long
'--assume you are working on Sheet 1
LastRow = Sheets(1).Cells(Rows.Count, Range("A1").Column).End(xlUp).Row
ReDim vArr(1 To LastRow)
For i = LBound(vArr) To UBound(vArr)
vArr(i) = "=Sum(RC[-2]:RC[-1])"
Next i
'--output this entire array with formulas into column C
Sheets(1).Range("C1").Resize(UBound(vArr)) = Application.Transpose(vArr)
End Sub
Output:
I'm by no means an expert in vba, but you could do this:
Sub macro()
Dim R As Long
R = 1
Do While Not IsEmpty(ActiveCell.Offset(0, -2))
Cells(R, "C").Select
R = R + 1
ActiveCell.Formula = "=sum(" & ActiveCell.Offset(0, -2) & "," &
ActiveCell.Offset(0, -1) & ")"
Loop
End Sub
I thought I'd recommend a slightly different course of action, just to give you ideas :):
Sub macro()
Dim found As Range
Set found = Range("A:A").Find("*", after:=Range("A1"), searchdirection:=xlPrevious)
If Not found Is Nothing Then
Range(Range("A1"), found).Offset(0, 2).FormulaR1C1 = "=RC[-2]+RC[-1]"
End If
End Sub