I want to know the code for inserting specified cells ranges below. For example, if I have a table with values from A2:F2, I want to create a code, which inserts a row below (i.e. A3:F3) and so on as and when the procedure is run. I want to insert rows only for specified range, not full row.
Sub InsertCells()
Dim ws As Worksheet
Dim LastRow As Long
Dim FirstHeaderCell As Range
Dim LastHeaderCell As Range
Set ws = ThisWorkbook.Sheets("sheet1") 'change here to your needs
Set FirstHeaderCell = ws.Range("A2") 'change here to your needs
Set LastHeaderCell = ws.Range("C2") 'change here to your needs
With ws
LastRow = FirstHeaderCell.Rows.End(xlDown).Row + 1
.Range(.Cells(LastRow, FirstHeaderCell.Column), .Cells(LastRow, LastHeaderCell.Column)).Insert xlShiftDown
End With
End Sub
You may not have merged cells under your table.
Related
I have a workbook with dynamic log sheet that performs calculations on data entered by the user. I would like specific dynamic columns copied from this log sheet to another sheet in the workbook for graphing purposes. This copy would only be for values and mainly is done to make it easier to run a final macro for producing a XY scatter plot. However, I am getting an object error and am not sure why this is happening. Thank you in advance for any and all help. Could you please help me figure out the best way to accomplish this task? Here is my current VBA:
Sub UpdateCharts()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim sourcelRow As Long
Dim targetlRow As Long
Set sourceSheet = ThisWorkbook.Worksheets("Inventory Log")
Set targetSheet = ThisWorkbook.Worksheets("Tables")
sourcelRow = sourceSheet.Cells(Rows.Count, 1).End(xlUp).Offset(-1, 0).Row
targetlRow = targetSheet.Cells(Row.Count, 6).End(xlDown).Offset(1, 0).Row
sourceSheet.Cells(sourcelRow, 1).Copy
targetSheet.Cells(targetSheet, 6).PasteSpecial xlPasteValues
End Sub
There are several errors/typos in your code:
you should always use explicit referencing
Row and Rows are two different commands
to retrieve the last row you should always use the same function
you don't need to copy/paste values - you can write them directly to
You could e.g. use this function to retrieve the last row of a sheet and columnIndex:
Public Function getLastRow(ws As Worksheet, columnIndex As Long) As Long
With ws
getLastRow = .Cells(.Rows.Count, columnIndex).End(xlUp).Row
End With
End Function
Then your code would look like this
Sub UpdateCharts()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim sourcelRow As Long
Dim targetlRow As Long
Set sourceSheet = ThisWorkbook.Worksheets("Inventory Log")
Set targetSheet = ThisWorkbook.Worksheets("Tables")
sourcelRow = getLastRow(sourceSheet, 1)
targetlRow = getLastRow(targetSheet, 6) + 1 'adding 1 row to have the next empty row
targetSheet.Cells(targetlRow, 6).Value = sourceSheet.Cells(sourcelRow, 1).Value
End Sub
I'm trying to copy a column from a table without it's header and transposing it into another part of the workbook.
To do so I've taken a piece of code that I've used before but can't quite tweak it to do what I want.
I was wondering if you could please help me?
I have table in "sheet 1" that has two columns and starts in cell "A3". I'm trying to copy column B, without the header, and transpose it into "sheet 2" from the cell "J2".
I can't do it via the macro recorder because if the table in sheet 1 only has one row it won't transpose into sheet 2 because it copies too many cells (and I'm learning more on how to avoid macro recorder).
This is the code I've tweaked, any help on how I can change it or use a better code?
'
' Macro21 Macro
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
'Set variables for copy and destination sheets
Set wsCopy = Worksheets("Sheet1")
Set wsDest = Worksheets("Sheet2")
'1. Find last used row in the copy range based on data in column 1
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Row
'2 Find first bnak row in the destination range based in column B
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row
'3. Copy & Paste Data
wsCopy.Range("B4").Copy wsDest.Range("J2" & lDestLastRow)
End Sub
Thanks
To copy a range and then paste it transposed, you can of course use .Copy and .PasteSpecial Transpose:=True, but it will be much better to resize your destination range in such a way that you shift the orientation of your copy range, and then to apply Application.Transpose() to the rngCopy.Value.
This code should do it. Some elaboration on your comments in there to explain what everything does.
Sub TransposeRangeColumn()
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Dim rngCopy As Range
'Set variables for copy and destination sheets
Set wsCopy = Worksheets("Sheet1")
Set wsDest = Worksheets("Sheet2")
'1. Find last used row in the copy range based on data in column B (!? you had "column 1")
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Row
'2. Set rngCopy
Set rngCopy = wsCopy.Range("B4:B" & lCopyLastRow)
'3. a) Resize destRang transposed. Example:
'Range("A1").Resize(RowSize=2, ColumnSize=3) would get you Range("A1:C2")
'we need to transpose, so input .Resize(rngCopy.ColumnSize, rngCopy.RowSize) instead
'we have 1 column, so just use 1 for the row; for columns, count rows rngCopy
'b) now that we have a transposed destination range, we want to set its value equal to
'a transposed version of rngCopy using Application.Transpose()
wsDest.Range("J2").Resize(1, rngCopy.Rows.Count).Value = Application.Transpose(rngCopy.Value)
'Code below would also have worked, but try to grow accustomed to using .Value = .Value instead
'it gives way better performance
'rngCopy.Copy
'wsDest.Range("J2").PasteSpecial Transpose:=True, Paste:=xlPasteValues
End Sub
You mentioned that your range is a table. If it is an actual Excel Table, you don't have to worry about finding/defining the first and last row of rngCopy. You can just set your range to the .DataBodyRange of the specific column you want (here: Column 2). Like this:
Sub TransposeTableColumn()
'Transpose if it's an actual table
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim rngCopy As Range
Set wsCopy = Worksheets("Sheet1")
Set wsDest = Worksheets("Sheet2")
'Use your table name instead of "Table1"
Set rngCopy = wsCopy.ListObjects("Table1").ListColumns(2).DataBodyRange
wsDest.Range("J2").Resize(1, rngCopy.Rows.Count) = Application.Transpose(rngCopy.Value)
End Sub
No need to use the clipboard and copy/paste operations. Do I direct write to cells and use WorksheetFunction.Transpose() to make the column into a row
Here is the code that worked for me
Option Explicit
Public Sub TestCopy()
CopyColumnTransposedTo
Sheets("Sheet1").Range ("A3"), _
2, _
Sheets("Sheet2").Range("J2")
End Sub
Public Sub CopyColumnTransposedTo(ByVal r_table As Range, column As Long, ByVal r_destination As Range)
' Move to the column on table
Set r_table = r_table.Cells(1, column)
' Count rows from end
Dim ws As Worksheet
Set ws = r_table.Worksheet
Dim count As Long
count = ws.Cells(ws.Rows.count, r_table.column).End(xlUp).Row - r_table.Row + 1
If count > 0 Then
' Copy transpose to destination
r_destination.Resize(1, count) = _
WorksheetFunction.Transpose( _
r_table.Resize(count, 1).Value)
End If
End Sub
Example results
I wanted to copy all visible rows from sheet1 table1 to sheet2 table2 after filter if Column B is empty. The code I have below only copy the last data to the other sheet and it will copy to the rest of the table.
Sub Send()
Dim i As Integer, j As Integer, k As Integer
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim visRng As Range ' Creating a range variable to store our table, excluding any rows that are filtered out.
Set wsCopy = Application.ThisWorkbook.Worksheets("Sheet1")
Set wsDest1 = Application.ThisWorkbook.Worksheets("Sheet2")
MsgBox "Sending Form...."
Set visRng = Range("Table1").SpecialCells(xlCellTypeVisible) 'Check all visible Rows in Table1
Dim r As Range
For Each r In visRng.Rows ' Loop through each row in our visible range ...
'MsgBox (r.Row) ' ... and retrieve the "absolute" row number.
If wsCopy.Cells(r.Row, 2).Value = "" Then
wsCopy.Range("A" & r.Row).Copy
wsDest1.Range("Table2").Columns(1).PasteSpecial
End If
Next
End Sub
here is sample filter in Sheet1 Table1
here is the result of my code in Sheet2 Table2
Expected Result: Sheet2 Table2
This should work:
Sub Send()
Dim i As Integer, j As Integer, k As Integer
Dim wsCopy As Worksheet
'IN THE CODE wsDest WAS CALLED wsDest1. I CHANGED THE REFERENCES IN THE CODE. I'D SUGGET YOU TO USE Option Explicit.
Dim wsDest As Worksheet
Dim visRng As Range ' Creating a range variable to store our table, excluding any rows that are filtered out.
'ADDED A NEW VARIABLE
Dim DblRow As Double
Set wsCopy = Application.ThisWorkbook.Worksheets("Sheet1")
Set wsDest = Application.ThisWorkbook.Worksheets("Sheet2")
MsgBox "Sending Form...."
'CHANGED visRng TO TARGET ONLY THE FIRST COLUMN OF Table1. NO NEED TO INCLUDE THE REST OF THE TABLE; IT WOULD ONLY MAKE OUR EXECUTION LONGER
Set visRng = Range("Table1").Columns(1).SpecialCells(xlCellTypeVisible) 'Check all visible Rows in Table1
'YOU SHOULD PUT THIS DECLARATION AT THE BEGINNING. ALSO I'D SUGGEST NOT TO USE A SINGLE LETTER VARIABLE. wsDest IS A GOOD NAME FOR A VARIABLE.
Dim r As Range
'SETTING THE VARIABLE.
DblRow = 1
For Each r In visRng.Rows ' Loop through each row in our visible range ...
'MsgBox (r.Row) ' ... and retrieve the "absolute" row number.
If wsCopy.Cells(r.Row, 2).Value = "" Then
wsCopy.Range("A" & r.Row).Copy
'YOUR CODE DIDN'T SCROLL THE TABLE 2. USING DBLROW IN .Cells YOU CAN DO IT.
wsDest.Range("Table2").Cells(DblRow, 1).PasteSpecial
DblRow = DblRow + 1
End If
Next
End Sub
Edits highlighted by proper comments.
Report any question you have or bug you have encountered. If, according to your judgment, this answer (or any other) is the best solution to your problem you have the privilege to accept it (link).
I am trying to loop through four tabs, copying data from three input tabs and pasting it into the remaining, master, tab. The code should loop through all the column headings on the master tab, find whether the same heading exists in any of input tabs and, if it does, copy and paste the data into the relevant column of the master tab.
At the moment, I have got all the data from the first input tab into the master tab but I am having difficulties getting data from the remaining input tabs to paste below the data from the first input tab.
This is the code as it stands at the moment:
Sub master_sheet_data()
Application.ScreenUpdating = False
'Variables
Dim ws1_xlRange As Range
Dim ws1_xlCell As Range
Dim ws1 As Worksheet
Dim ws2_xlRange As Range
Dim ws2_xlCell As Range
Dim ws2 As Worksheet
Dim ws3_xlRange As Range
Dim ws3_xlCell As Range
Dim ws3 As Worksheet
Dim ws4_xlRange As Range
Dim ws4_xlCell As Range
Dim ws4 As Worksheet
Dim valueToFind As String
Dim lastrow As String
Dim lastrow2 As String
Dim copy_range As String
'Assign variables to specific worksheets/ranges
'These will need to be updated if changes are made to the file.
Set ws1 = ActiveWorkbook.Worksheets("Refined event data - all")
Set ws1_xlRange = ws1.Range("A1:BJ1")
Set ws2 = Worksheets("Refined event data")
Set ws2_xlRange = ws2.Range("A1:BJ1")
Set ws3 = Worksheets("Refined MASH data")
Set ws3_xlRange = ws3.Range("A1:BJ1")
Set ws4 = Worksheets("Raw RHI data - direct referrals")
Set ws4_xlRange = ws4.Range("A1:BJ1")
'Loop through all the column headers in the all data tab
For Each ws1_xlCell In ws1_xlRange
valueToFind = ws1_xlCell.Value
'Loop for - Refined event data tab
'check whether column headers match. If so, paste column from event tab to relevant column in all data tab
For Each ws2_xlCell In ws2_xlRange
If ws2_xlCell.Value = valueToFind Then
ws2_xlCell.EntireColumn.Copy
ws1_xlCell.PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws2_xlCell
'Loop for - Refined ID data tab
'check whether column headers match. If so, paste column from MASH tab to the end of relevant column in all data tab
For Each ws3_xlCell In ws3_xlRange
If ws3_xlCell.Value = valueToFind Then
Range(ws3_xlCell.Address(), ws3_xlCell.End(xlDown).Address()).Copy
lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws3_xlCell
'Loop for - direct date data tab
'check whether column headers match. If so, paste column from direct J4U tab to the end of relevant column in all data tab
For Each ws4_xlCell In ws4_xlRange
If ws4_xlCell.Value = valueToFind Then
Range(ws4_xlCell.Address(), ws4_xlCell.End(xlDown).Address()).Copy
lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws4_xlCell
Next ws1_xlCell
End Sub
At the moment, this section of code:
For Each ws3_xlCell In ws3_xlRange
If ws3_xlCell.Value = valueToFind Then
Range(ws3_xlCell.Address(), ws3_xlCell.End(xlDown).Address()).Copy
lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws3_xlCell
Seems to be selecting the correct range on the correct sheet and copying it. The lastrow variable seems to be picking up the correct row on the master tab but the data is not pasted. I've tried naming the ranges and using Cells() rather than Range() but neither appeared to work.
Any ideas as to how to get the data to paste would be much appreciated.
Cheers,
Ant
What I did was make a function that would find the column header and return the data range from from that column.
Sub master_sheet_data()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim cell As Range, source As Range, target As Range
With ThisWorkbook.Worksheets("Raw RHI data - direct referrals")
For Each ws In Worksheets(Array("Refined event data - all", "Refined event data", "Refined MASH data"))
For Each cell In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft))
Set source = getColumnDataBodyRange(ws, cell.Value)
If Not source Is Nothing Then
Set target = cell.Offset(.Rows.Count - 1).End(xlUp).Offset(1)
source.Copy
target.PasteSpecial xlPasteValuesAndNumberFormats
End If
Next
Next
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Function getColumnDataBodyRange(ws As Worksheet, ColumnHeader As Variant) As Range
Dim cell As Range
With ws
Set cell = .Rows(1).Find(What:=ColumnHeader, After:=.Range("A1"))
If Not cell Is Nothing Then
Set getColumnDataBodyRange = .Range(cell.Offset(1), cell.Offset(.Rows.Count - 1).End(xlUp))
End If
End With
End Function
I am trying to clear all the columns after the last header row
The macro runs but no clearing happens, I have played with the syntactic for awhile and am not getting it
Thanks
Sub ClearColumnsAfterLastHeader()
Dim ws As Excel.Worksheet
Dim hNames As Variant
Dim cell
Set ws = ActiveWorkbook.Sheets("Finished")
hNames = ws.Range("A1:R1").Value
For Each cell In hNames
If IsEmpty(cell) Then
cell.EntireColumn.ClearContents
End If
Next cell
End Sub
The main problem of your code is that hNames is array of Variant rather than Range and when you're looping through array For Each cell In hNames, variable cell refers to array element rather than to corresponding cell. So, you can't use cell.EntireColumn.ClearContents, because cell is not Range, but Variant.
As per my understanding of question, you want to determine last filled cell in first row (header row) and clear contents of all columns to the right of last filled header. In that case try code below:
Sub ClearColumnsAfterLastHeader()
Dim ws As Excel.Worksheet
Dim lastHeaderColumn As Long
Set ws = ActiveWorkbook.Sheets("Finished")
With ws
'determine last filled cell in first row
lastHeaderColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
'get of all cells to the right and down and clear contents
.Range(.Cells(1, lastHeaderColumn + 1), _
.Cells(.Rows.Count, .Columns.Count)).ClearContents
End With
End Sub
Cant you just do something like
Sub ClearStuff()
Dim ws As Worksheet
Dim LastCell As Range, ClearRange As Range
Set ws = ActiveWorkbook.Sheets("Finished")
Set LastCell = ws.Cells(1, ws.Columns.Count)
Set ClearRange = Range(LastCell.End(xlToLeft).Offset(0, 1), LastCell)
ClearRange.EntireColumn.ClearContents
End Sub