In Sheet1, I have rows of data points for several different measures (columns). I manually created a second sheet which performs some analysis on the first column of data. How can I create a macro or VBA code such that a new sheet is created for each of the columns in Sheet1 and the exact same analysis is performed as the one I created manually? Thanks.
Create a "template" analysis sheet with a place to paste a column of data, then make copies of that template and copy-paste in the relevant column from Sheet1.
Eg:
Sub Tester()
Dim rngData As Range, col As Range, colNum As Integer
Dim shtTemplate As Worksheet, shtData As Worksheet
Set shtData = Sheets("Sheet1")
Set shtTemplate = Sheets("Template")
Set rngData = shtData.Range("A1").CurrentRegion
colNum = 0
For Each col In rngData.Columns
colNum = colNum + 1
shtTemplate.Copy before:=shtTemplate
With Sheets(shtTemplate.Index - 1)
.Name = "Column " & colNum
col.Copy .Range("A1")
End With
Next col
End Sub
Related
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 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.
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 need help to create an automatic method to copy a row to a specific sheet.
I have a Tab (Sales) with a WEB api query importing data in this sheet every 5 min. I have a row within the Sales sheet with a name range identifying each item. The row has 100 different names and there are 100 sheets created with same names within the workbook.
I want to copy the entire row for each item and copy it to the sheet with the same name of the item.
This is to fire off the copy sub:
'Copy Sales data Every 10 Min
Sub test()
'Application.OnTime Now + TimeValue("00:10:00"), "my_Procedure…"
End Sub
I have seen many methods on how to copy the row automatically, but I need help in copy row and use the item name and paste to other sheet with same name.
Without further information here is an outline of what i described in the comments. Here the list of named ranges starts at cell J3 in NamesSheet. In the image, i have shown it in the same sheet (SourceSheet for simplicity). The list is read into an array and that array is looped to select the appropriate sheet to set the values in.
Rather than copy and paste it sets the target row (the next available row), in the sheet accessed by the array index, equal to the source row (copyRow). A With statement is used to avoid selecting the target sheet (more efficient).
No error handling added for missing sheets at present.
I haven't assumed there will be a list of 100 named ranges in the sheet, otherwise you could have sized the array from the start.
Named ranges in ColA of Sales tab:
List of named ranges in Names sheet (abbreviated)
Option Explicit
Private Sub myProc()
Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsNames As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sales")
Set wsNames = wb.Worksheets("Names")
Dim namesArr()
namesArr = wsNames.Range("J3:J" & wsNames.Cells(wsNames.Rows.Count, "J").End(xlUp).Row).Value
If UBound(namesArr, 1) <> wsSource.Range("ITEMName").Rows.Count Then
MsgBox "There are not a matching number of named ranges listed in Names sheet."
Exit Sub
End If
Dim i As Long
Dim currLastRow As Long
'Any optimization code could actually go in outer calling sub but consider
'some such as the following
Application.ScreenUpdating = False
Dim copyRow As Range
For i = LBound(namesArr, 1) To UBound(namesArr, 1)
With wb.Worksheets(namesArr(i, 1))
Set copyRow = wsSource.Range(namesArr(i, 1)).EntireRow
If IsEmpty(.Range("A1")) Then 'First row in sheet is available
.Rows(1).Value = copyRow.Value2
Else
currLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Rows(currLastRow + 1).Value = copyRow.Value2
End If
End With
Next i
Application.ScreenUpdating = True
End Sub
Version 2:
Looping Named Ranges in Sales sheet (assumes only 101 Named Ranges in the sheet, tested with workbook scope, and that you will ignore 1 of these which is called ITEMName, no list required in a different sheet. Approach adapted from #user1274820.
Option Explicit
Private Sub myProc2()
Dim wb As Workbook
Dim wsSource As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sales")
Dim currLastRow As Long
'Any optimization code could actually go in outer calling sub but consider
'some such as the following
Application.ScreenUpdating = False
Dim copyRow As Range
Dim nm As Variant
For Each nm In ThisWorkbook.Names
If nm.RefersToRange.Parent.Name = "Sales" And nm.Name <> "ITEMName" Then
With wb.Worksheets(nm.Name)
Set copyRow = wsSource.Range(nm.Name).EntireRow
If IsEmpty(.Range("A1")) Then 'First row in sheet is available
.Rows(1).Value = copyRow.Value2
Else
currLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Rows(currLastRow + 1).Value = copyRow.Value2
End If
End With
End If
Next nm
Application.ScreenUpdating = True
End Sub
The workbook has approx 50 spredsheets with a unique name. Each spreadsheet has data till column "F".
I would like to pull the spreadsheet name in one column and max data from column "C" in each spreadsheet to the next column though I know that the max data is from perticular spreadsheet.
How's something like this:
Sub get_Max()
Dim mainWS As Worksheet, ws As Worksheet
Dim rng As Range, cel As Range
Dim i%
Set mainWS = Sheets("Sheet1") ' Change this to meet your criteria. This is where the data will go
For i = Sheets.Count To 0 Step -1
If Worksheets(i).Name = mainWS.Name Then Exit For
' Let's first list the sheet names in Column A of our mainWS
mainWS.Cells(i, 1).Value = Sheets(i).Name
' Then get the max value from column C ('3').
mainWS.Cells(i, 2).Value = WorksheetFunction.Max(Sheets(i).Range(Sheets(i).Columns(3), Sheets(i).Columns(3)))
Next i
End Sub