the thing is I want to copy a certain column but I want to only copy data on a specific cell and get the data below it.
Let say for example, I want to copy Cell C5 and below, this will disregard C1 to C4. Is this possible?
Further to my comments below your question, here is one way. This will work in all scenarios. Whether you have blank cells or not...
Option Explicit
Sub CopyCells()
Dim ws As Worksheet
Dim rng As Range
Dim sRow As Long, lRow As Long
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
sRow = 5 '<~~ Starting row
With ws
'~~> Find last row in Col C
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
'~~> If the last row < Start Row
If lRow < sRow Then
MsgBox "Start Row cannot be greater then last row"
Else
'~~> Create your range
Set rng = .Range("C" & sRow & ":C" & lRow)
'~~> Copy
rng.Copy
'
' Do what you want with copied data
'
End If
End With
End Sub
Sheet1.Columns(3).Resize(Sheet1.Columns(3).Rows.Count - 4).Offset(4).Select
This will select entire C column but first 4 cells. It simply take column 3, resize it to subtract first 4 cells and offset the starting cell 4 cell below and select that range.
If your range is defined then code could be more optimized.
EDIT for sample code:
Sub copyCells()
Dim sht As Worksheet
Dim rngStart As Range
Dim rng As Range
Set sht = Sheet1
Set rngStart = sht.Cells(5, 3) ' this is C5
rngStart.Select
Set rng = rngStart.Resize(rngStart.End(xlDown).Row - rngStart.Row + 1)
rng.Copy Sheet2.Cells(1, 1) ' copy where you need
End Sub
This will copy a entire column (with data) from selection, just paste it wherever you want.
Sub CopyColumnFromSelected()
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
End Sub
Or (Ctrl + Shift + down arrow) <--- from your desired cell and Ctrl+C ;)
Related
I have a excel which has multiple rows and columns and range of column values differ for each row.
Need a macro which will delete all cells in a row except first and last in each row and paste the last value next to first value.
Tried the below script:
Sub test()
Dim sh As Worksheet
Dim IDS As range
Dim ID As range
Set sh = ThisWorkbook.Sheets("Sheet1")
Set IDS = ActiveSheet.range("A2", range("A1").End(xlDown))
For Each ID In IDS
Dim b As Integer
Dim k As Integer
k = sh.range("ID", sh.range("ID").End(xlToRight)).Columns.Count
b = k - 1
range(ID.Offset(0, 0), ID.Offset(0, "b")).Select
Selection.ClearContents
Next ID
End Sub
This is a little different approach but should help.
Also, it is generally not best to declare variables in a loop as you do with b & k just fyi
Sub test()
Dim sh As Worksheet
Dim row As Integer
Dim lastCol As Integer
Set sh = ThisWorkbook.Sheets("Sheet1")
For row = 2 To sh.Cells(Sheets(1).Rows.Count, "A").End(xlUp).row
lastCol = sh.Cells(row, Columns.Count).End(xlToLeft).Column
sh.Range("B" & row).Value = sh.Cells(row, lastCol).Value
sh.Range(sh.Cells(row, 3), sh.Cells(row, lastCol)).ClearContents
Next
End Sub
Best of luck
I'd go as follows:
Sub test()
Dim cell As Range
With ThisWorkbook.Sheets("Sheet1") ' reference relevant sheet
For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) ' loop through referenced sheet column A cells from row 2 down to last not empty one
With .Range(cell, .Cells(cell.Row, .Columns.Count).End(xlToLeft)) ' reference referenced sheet range spanning from current cell to last not empty one in the same row
If .Count > 2 Then ' if referenced range has more then 2 cells
cell.Offset(, 1).Value = .Cells(1, .Count).Value ' store last cell value next to the current one
.Offset(, 2).Resize(, .Columns.Count - 1).ClearContents 'clear all cells right of current one
End If
End With
Next
End With
End Sub
You can use Range.Delete Method (Excel)
range(ID.Offset(0, 0), ID.Offset(0, b)).Delete Shift:=xlToLeft
I am working with the excel-vba, I have to sort the rows in ascending order with merged cells, I know that the merged cell cannot be sorted that is why, this work around is the only solution to my problem. I need to unmerged the cells then copy the value of the first cell and paste it to the second cell, after that, the code will sort the list using the A column and C column. and then after that if the A and C column has an equal value, it will turn to merged cell.
I hope someone could help me with this project.
Also view this image to see the list.
Sort
So, I constructed a code that will do this process but it cant.
Sub Sort()
On Error GoTo myErr
Dim myRange As Range
Dim lstrow As Long
Dim i As Integer
Dim cel As Range
Set myRange = Sheet1.Range("A2:C7")
lstrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
With myRange
.UnMerge
For Each cel In myRange
If IsEmpty(cel) Then
For i = 2 To lstrow
' cel(i).Value = 1
Sheet1.Range(i).Copy Sheet1.Range(cel).PasteSpecial
Sheet1.Range("C3").CurrentRegion.Sort _
key1:=Sheet1.Range("C3"), order1:=xlAscending, _
Header:=xlGuess
Next i
End If
Next cel
End With
myErr:
MsgBox "Unble to sort!"
End Sub
“No one is useless in this world who lightens the burdens of another. -Charles Dickens”
Regards,
If you are going to find lstRow before unmerging, use Column B — if the last row in Column A is merged, then the bottommost cell is empty! Or if you prefer, you can find lstRow after unmerging everything.
By looping through myRange you can both UnMerge any merged cells and populate the newly unmerged cells using the MergeArea.address of the original merged cell. After sorting on columns A and C, you can then loop through those columns, comparing each row to the row beneath. Only re-merge when both the row beneath is the same as the row above for both columns.
Option Explicit
Sub Sort()
Dim myRange As Range
Dim lstrow As Long
Dim l As Long
Dim rng As Range
Dim address As String
Dim contents As Variant
Dim ws As Worksheet
On Error GoTo myErr
Set ws = ThisWorkbook.Sheets("Sheet1")
Set myRange = ws.Range("A1:C7")
' Get lstrow from Column B, if Column A has merged cells
lstrow = ws.Cells(Rows.Count, 2).End(xlUp).Row
' Unmerge and populate
For Each rng In myRange
If rng.MergeCells Then
' Get value from top left cell
contents = rng.MergeArea.Cells(1).Value
address = rng.MergeArea.address
rng.UnMerge
ws.Range(address).Value = contents
End If
Next rng
' Sort
myRange.Sort key1:=ws.Range("A1:A" & lstrow), _
order1:=xlAscending, Header:=xlYes, key2:=ws.Range("C1:C" & lstrow), _
order2:=xlAscending, Header:=xlYes
' Turn off alerts
Application.DisplayAlerts = False
' Re-merge
With ws
For l = 2 To lstrow
If .Cells(l, 1).MergeArea.Cells(1).Value = .Cells(l + 1, 1).MergeArea.Cells(1).Value _
And .Cells(l, 3).MergeArea.Cells(1).Value = .Cells(l + 1, 3).MergeArea.Cells(1).Value Then
' Merge column A
Range(.Cells(l, 1).MergeArea, .Cells(l + 1, 1)).Merge
' Merge column C
Range(.Cells(l, 3).MergeArea, .Cells(l + 1, 3)).Merge
End If
Next l
End With
' Turn on alerts
Application.DisplayAlerts = True
Exit Sub
myErr:
MsgBox "Unable to sort!"
End Sub
I wrote a code to copy Column D, H, M and paste it on a brand new sheet starting from A-C. I first find the last row , after that I Union the 3 column range together then select the sheet and paste it.
For some reason I don't understand why it does not work. I have never used Union range before so not sure if that is the problem, or if it is something like my for loop. Help would be appreciated.
Dim ws As Worksheet
Dim lastRow As Integer
'for loop variables
Dim transCounter As Integer
Dim range1 As Range
Dim range2 As Range
Dim range3 As Range
Dim multipleRange As Range
Dim lastRow1 As Integer
Dim ittercell As Integer
Set ws = ActiveSheet
For transCounter = 1 To 10
r.AutoFilter Field:=6, Criteria1:=transCounter.Value, Operator:=xlFilterValues
With Application.ActiveSheet
lastRow1 = .Cells(.Rows.Count, "AE").End(xlUp).Row
End With
Set range1 = Sheets("Sheet1").Range("D6:D" & lastRow1).SpecialCells(xlCellTypeVisible)
Set range2 = Sheets("Sheet1").Range("H6:I" & lastRow1).SpecialCells(xlCellTypeVisible)
Set range3 = Sheets("Sheet1").Range("M6:M" & lastRow1).SpecialCells(xlCellTypeVisible)
Set multipleRange = Union(range1, range2, range3)
multipleRange.Copy
Sheets("O1 Filteration").Select
'Range("A3").Select
'Range("A3").PasteSpecial xlPasteValues
ittercell = 1
Cells(3, ittercell).PasteSpecial xlPasteValues
ittercell = ittercell + 6
Next transCounter
There's a couple of issues with your code that might be causing the fault:
r is not defined in your code
use of transCounter.Value instead of just CStr(transCounter) (see #QHarr comment)
iterCell reset every iteration of the loop (see #QHarr comment)
Combination of ActiveSheet, unqualified Cells(... and manual Select on sheets makes the Range qualifications ambiguous
However, I do think the main logic of using Union, then Copy, then PasteSpecial is OK and just some tweaking is required.
Here is some working code where you update the Worksheet and Range references with your own. Please follow the comments.
Option Explicit
Sub CopyUnionColumns()
Dim wsSource As Worksheet '<-- Sheet1 in your code
Dim wsTarget As Worksheet '<-- O1 Filteration in your code
Dim rngFilter As Range '<-- main data range on Sheet1
Dim rngSource As Range '<-- to hold Union'd data after filtering
Dim rngTarget As Range '<-- range in O1 Filteration to paste code to
Dim lngLastRow As Long '<-- last row of main data
Dim lngCounter As Long '<-- loop variable
Dim lngPasteOffsetCol As Long '<-- offset column for pasting in the loop
' set references to source and target worksheets
Set wsSource = ThisWorkbook.Worksheets("Sheet2") '<-- update for your workbook
Set wsTarget = ThisWorkbook.Worksheets("Sheet3") '<-- update for your workbook
' set reference to data for filtering in source worksheet
lngLastRow = wsSource.Cells(wsSource.Rows.Count, 6).End(xlUp).Row
Set rngFilter = wsSource.Range("A1:F" & lngLastRow)
' initialise offset column
lngPasteOffsetCol = 0
' iterate rows
For lngCounter = 1 To 10
' filter data the data per the counter
rngFilter.AutoFilter Field:=6, Criteria1:=CStr(lngCounter), Operator:=xlFilterValues
' set source range as union of columnar data per last row
Set rngSource = Application.Union( _
wsSource.Range("A1:A" & lngLastRow).SpecialCells(xlCellTypeVisible), _
wsSource.Range("C1:C" & lngLastRow).SpecialCells(xlCellTypeVisible), _
wsSource.Range("E1:E" & lngLastRow).SpecialCells(xlCellTypeVisible))
' set target range on target sheet top left cell and offset column
Set rngTarget = wsTarget.Range("A1").Offset(0, lngPasteOffsetCol)
' copy source cells
rngSource.Copy
' paste to target
rngTarget.PasteSpecial Paste:=xlPasteAll
' increment offset
lngPasteOffsetCol = lngPasteOffsetCol + 6
Next lngCounter
' cancel cut copy mode
Application.CutCopyMode = False
' cancel autofilter
wsSource.AutoFilterMode = False
End Sub
Rng1.Copy Destination:=Worksheets("RefindData").Range(Destination)
Where Rng1 is the range of data to be copied and Destination is currently a cell reference (E.g B2)
This code will be called multiple times. How can I alter this so that the destination is the same column (E.g column B) but the row is the next empty cell?
E.g so on the first call, B2 onwards is where the values are copied to, then on the next call the next empty cell after the first call is where the second call should start outputting its values. Then the next empty cell for the start of the third call, and so on.
I can alter the Destination variable to just state column letter if something like this:
Rng1.Copy Destination:=Worksheets("RefindData").Range(Destination & ???)
Is along the right lines?
Sub CopyPasteCells()
Dim Rng1 As Range, Rng2 As Range, ws As Worksheet
Set ws = Worksheets("RefindData")
Set Rng1 = ws.Range("C2:C10") 'Copy range as you like
Set Rng2 = ws.Range("B" & ws.Rows.Count).End(xlUp).Offset(1, 0) 'Paste range starting from B2 and then first empty cell
Rng1.Copy Destination:=Rng2 'Copy/Paste
End Sub
You can also try something like code below.
Assumptions:
Active cell is in the column, where you want to paste the results (you want to paste results in column B -> select cell from B column [for example B2],
The first row is filled with headers, so the results gonna be pasted from second row
Code
Sub CutCopyPaste()
Dim lngCol As Long
Dim rngCopy As Range
Set rngCopy = Range("A1") 'The cell which ic copied
lngCol = Selection.Column 'active column where the results will be pasted
On Error Resume Next
rngCopy.Copy Cells(Cells(1, lngCol).End(xlDown).Row + 1, lngCol)
If Err.Number = 1004 Then
MsgBox "Be sure that active cell is in the column, where the results should be pasted!" & vbNewLine & vbNewLine & "Try again"
Err.Clear
End If
End Sub
You mean like this?
Sub Sample()
Dim rng1 As Range
Dim wsO As Worksheet
Set wsO = Worksheets("RefindData")
Set rng1 = Range("A1:A10")
rng1.Copy Destination:=wsO.Range("B" & _
wsO.Range("B" & wsO.Rows.Count).End(xlUp).Row + 1)
End Sub
Every time you run the macro it will paste in the next available row after the last row.
VBA Copy column and paste formulas only - not values - to next column
Spreadsheet column B has a random mix of values and formulas. I want to use VBA to copy that column into the next column and only copy the formulas (not the values) into column C. I was able to use the following VBA to some success but it copies every column past B to infinity (where I want it to stop copying after the first column).
Sub Copy_Column_Formulas_NOvalues()
'
' Copy_Column_Formulas_NOvalues Macro
'
Dim oSheet As Worksheet
Dim rng As Range
Dim cel As Range
Set oSheet = Sheets("Sheet1")
With oSheet
Set rng = .Range(.Range("B1"), .Range("B" & .Rows.Count).End(xlUp))
For Each cel In rng
If Left(cel.Formula, 1) = "=" Then
Range(cel.Offset(, 1), cel.Offset(, 1).End(xlToRight)).FormulaR1C1 = cel.FormulaR1C1
End If
Next cel
End With
End Sub
Try this simple macro and let me know if it works,
Sub Copy_Column_Formulas_NOvalues()
Dim i As Long, j As Long
For i = 1 To Sheets("Sheet3").Cells(Rows.Count, "B").End(xlUp).Row
If Cells(i, 2).HasFormula Then
Cells(i, 3) = Cells(i, 2).Formula
End If
Next i
End Sub
Change the Sheet3 name as per your needs.