I have been racking my brain over this code. I am trying to copy a set of data from table "CST" to the end of a currently populated table titled "HT_Table" and input the type of test that was run for the entries I am pasting. The historical data table should have a running list of entries.
Each time I run the macro I want to copy "[[Social Security Number]:[Rehire Date]]" into the bottom of a different table that has a running list of selections and add "Loan" to the right of it under the "Test" column.
Sub Copy_Data
'Copy critical data
Dim tbl As ListObject
Set tbl = CST.ListObjects(1)
Range(tbl & "[[Social Security Number]:[Rehire Date]]").Copy
Windows("Historical Testing.xlsx").Activate
'I named the column in the table I am pasting to "SSN"
Range("SSN").End(xlDown).Select
ActiveCell.Offset(1, 0).PasteSpecial
Dim PY As Worksheet
Set PY = ActiveSheet
With PY.ListObjects("HT_Table")
.ListColumns("Test").Range.Select
ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)) = "Loan"
End With
End Sub
I run into problems with the Selection.End(x1Down)) if there is only one row pasted to the bottom of the table. The above code selects the one row and then highlights all the way to the end of the worksheet.
Related
Question
I'm trying to do something that may be very simple using Excel but I can't find how to do it.
I have several worksheets, each one contains a single table. To give you an example, here are two of my worksheets :
First worksheet. Please note that lines are green.
Some data. Without 's', sorry :-)
Second one. Lines are grey but cells can be red. Headers are NOT the same
I would like to :
merge those tables into another worksheet
keep style formatting (line color, etc)
when I update a table, the merged one should update too (may be a macro)
Here is a possible output :
Note that same headers are correctly merged.
Can I do this with Excel ? I know that I can do a query (UNION ALL) but doing this doesn't preserve style formatting.
Edit 1
I've tried to build the table using microsoft queries. Here is my query :
SELECT * FROM `C:\Users\cflodrops\Downloads\comptes.xlsx`.`Purchases$` `Purchases$`
UNION ALL
SELECT * FROM `C:\Users\cflodrops\Downloads\comptes.xlsx`.`Sales$` `Sales$`
UNION ALL
SELECT * FROM `C:\Users\cflodrops\Downloads\comptes.xlsx`.`Trades$` `Trades$`
UNION ALL
SELECT * FROM `C:\Users\cflodrops\Downloads\comptes.xlsx`.`Transfers$` `Transfers$`
This request works great, here is the result :
But I still have issues :
style formatting is incorrect (background colors and numbers format)
datas are not synchronized between arrays. It's not an issue, I can create a macro to execute the request whenever I click on a button.
you have a few problems...union can work. Assuming union path from your first edit.
Add placeholder columns on both sheets to allow proper union, OR force placeholders columns in with your t-sql queries.
Add columns to each sheet representing the source OR add these in with your t-sql queries. e.g. 'Sheet1'
On your unioned sheet with the results, add conditional formatting, where the row with the cell of the source type is evaluated, then the entire row is formatted as necessary. e.g. cell A2 has 'Sheet1', then row A is colored green.
If i understand you well, you want to:
copy data preserving formatting from existing sheets and put them into another sheet (new or existing; let's call it "merged data"),
keep one-way synchronization betweem source sheets and "merged sheet", which means when source sheet is changing, a "merged sheet" changes too.
The answer for both issues is YES depending on a way you choose to merge/synchronize/display data...
Method #1 - using copy & paste data one below another
This method will preserve formatting, but there's no chance to update destination table (sheet) when source data have been changed. You'll need to create it every time you want to see merged data.
Method #2 - using Range.CopyFromRecordset method together with UNION statement
If you want to use this method, you have to change your data set into model of relational database. There's no chance for preserving source formatting, but "merged sheet" may be quickly reloaded (a'ka updated).
Both methods of copying data between sheets you'll find here: Copy Data Between Excel Sheets using VBA, but this tip does not provide information about copying data within its originall format. So, i decided to clarify how to achieve that and show/provide code which create destination sheet with merged data.
In my example i have 3 sheets. First and second sheet is used as source of data and the 3. one is used to display merged data. Only 3 columns (A-C) contain data, so ranges to copy are hard-coded.
Option Explicit
'method #1
Private Sub CopyWithFormatting(srcSh As Worksheet, dstSh As Worksheet, Optional sCol As String = "A")
Dim e1 As Long, e2 As Long
On Error GoTo Err_CopyWithFormatting
'last row in src and dst sheet
e1 = srcSh.Range(sCol & srcSh.Rows.Count - 1).End(xlUp).Row
e2 = dstSh.Range(sCol & dstSh.Rows.Count - 1).End(xlUp).Row + 1
'do not refresh screen
Application.ScreenUpdating = False
'copy defined range
srcSh.Range("A2:C" & e1).Copy
'paste below existing data
With dstSh.Range("A" & e2)
.PasteSpecial xlPasteAllUsingSourceTheme
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValidation
End With
Exit_CopyWithFormatting:
On Error Resume Next
'restore default settings
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
Exit Sub
Err_CopyWithFormatting:
MsgBox Err.Description, vbExclamation, "Err no. " & Err.Number
Resume Exit_CopyWithFormatting
End Sub
How to use it?
Sub TestMethod1()
Dim CopiedSheet As Worksheet, DestSheet As Worksheet
'as i mentioned -> 3. sheet is used to merge data
'you can change it by using sheet's name or its index
Set DestSheet = ThisWorkbook.Worksheets(3)
'copy data from sheets into destination sheet
For Each CopiedSheet In ThisWorkbook.Worksheets
'ignore destination sheet
If CopiedSheet Is DestSheet Then GoTo SkipNext
CopyWithFormatting CopiedSheet, DestSheet
SkipNext:
Next
End Sub
Finall note: Feel free to change above code to your needs.
In the third sheet I would have a macro in the Activate event, that pulls the data from from the first two sheets. I would add a hidden column in the third sheet that contains to originating sheet. In your conditional formatting for the third sheet you would need to base your formatting on the value in the hidden column. I can post a sample to clarify if you wish.
EDIT: Added sample
Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Dim Sheet3 As Worksheet
Set Sheet1 = Worksheets(1)
Set Sheet2 = Worksheets(2)
Set Sheet3 = Worksheets(3)
Sheet1.Range("A2:D101").Copy
Sheet3.Cells(2, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheet2.Range("A2:D101").Copy
Sheet3.Cells(102, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheet3.Cells(1, 1).Select
ActiveWorkbook.Worksheets("Sheet3").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet3").AutoFilter.Sort.SortFields.Add Key:=Range _
("A1:A201"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Sheet3").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Here is an example file.
ConcatSheets Example.xlsm
I am trying to insert a column into the sheet and copying the formulas into it from the adjacent column to the right.
The place to insert the column is being read from the work sheet itself. E.G Column S (Column 19).
So I need to insert a new Column at Column "S" and copy the formulas from the "Old" Column S, now Column T.
I am using the following code but it is giving me 1004 error.
Sub Insert_Rows_Loop()
Dim CurrentSheet As Object
'MsgBox "ghj" & Sheet16.Range("H2").Value
Sheet2.Cells(1, Sheet16.Range("H2").Value).EntireColumn.Select
Selection.Copy
Selection.Insert Shift:=xlToLeft
Application.CutCopyMode = False
Sheet2.Cells(1, Sheet16.Range("G2").Value).EntireColumn.Select
Selection.Copy
Selection.Insert Shift:=xlToLeft
Application.CutCopyMode = False
Sheet2.Cells(1, Sheet16.Range("F2").Value).EntireColumn.Select
Selection.Copy
Selection.Insert Shift:=xlToLeft
Application.CutCopyMode = False
End Sub
The code below will do the following:
Insert a new Column to the left of current Column S
Set the Formulas in Column S to the Formulas in Column T (Old Column S) to Column S
Dim CurrentSheet As Worksheet
Set CurrentSheet = ThisWorkbook.Sheets("Sheet1")
With CurrentSheet
'Inserting the Column before Column S
.Range("S1").EntireColumn.Insert
'Copying the Formulas from the T(Old S) to S
.Range("S1").EntireColumn.Formula = .Range("T1").EntireColumn.Formula
End With
You need to adjust the value in the Range to suit your requirement and you Sheet Referencing will be different.
I hope you get the idea behind it.
Your sample code is indicative of the problems that are encountered when relying upon .Select and .Activate methods to navigate and reference various cells and worksheets in a workbook. Avoid .Select and .Activate in favor of direct cell referencing¹.
The second issue is no predetermined order for the column insertion. While you can insert columns in a seemingly random order, if there is an ascending pattern to the column numbers the latter columns will change position when a column is previously inserted to the right of it. The 'best practise' is to insert the columns starting at the right and working toward column A.
The following has been based on what your sample code said as it does not follow the same flow as your narrative.
Sub Insert_Rows_Loop()
Dim c As Long, arr As Variant
With Sheet16
ReDim arr(2)
'get them in descending order so that inserting 1 does not change the position of 2 or 3
arr(0) = Application.Large(.Range("F2:H2"), 1)
arr(1) = Application.Large(.Range("F2:H2"), 2)
arr(2) = Application.Large(.Range("F2:H2"), 3)
End With
With Sheet2
For c = LBound(arr) To UBound(arr)
With .Columns(arr(c))
.Copy
.Insert Shift:=xlToLeft
End With
Next c
End With
Application.CutCopyMode = False
End Sub
¹ See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
I want to make drop Down List in sheet2 which contains values from sheet1 column. I have tried this code.
Sub testIt()
Dim r As Long, endRow As Long, pasteRowIndex As Long
endRow = 10 ' of course it's best to retrieve the last used row number via a function
pasteRowIndex = 1
For r = 1 To endRow 'Loop through sheet1 and search for your criteria
If Cells(r, Columns("B").Column).Value = "YourCriteria" Then 'Found
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("Sheet2").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
'Switch back to your table & continue to search for your criteria
Sheets("Sheet1").Select
End If
Next r
columns in sheet1 are changing oftenly. so needs to create Dynamic VBA Macro code.
Please guide me for this query.
For your case, I don't think that you need a macro to manage the drop down list but perhaps data validation will do.
Create a new worksheet,
I got a worksheet contain the following data at column A
At the worksheet that i want the dropdownlist, i just highlight the cell and click on the data validation button at data ribbon
In the data validation, create the following setting
Click on the ok button and the list will be created
Since in the columns in the worksheet(source) keep on changing, you need write the macro to copy the entire needed column exclude the header of the column to next worksheet(e.g. worksheet that create the dropdown list).
Edited: Code to detect the criteria column and copy the column
Option Explicit
Dim MyWorkbook As Workbook
Dim MyWorksheet As Worksheet
Dim MyWorksheet2 As Worksheet
Dim WantedColumn As Long
Dim ColumnPointer As Long
Sub copyCriteria()
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set MyWorksheet = MyWorkbook.Sheets("Sheet6")
Set MyWorksheet2 = MyWorkbook.Sheets("Sheet5")
For ColumnPointer = 1 To MyWorksheet.Cells(1, Columns.Count).End(xlToLeft).Column
If MyWorksheet.Cells(1, ColumnPointer).Value = "ColumnE" Then
MyWorksheet.Columns(ColumnPointer).Copy
MyWorksheet2.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
MyWorksheet2.Rows("1:1").Delete Shift:=xlUp
End If
Next
End Sub
What you are trying to do can be done with a simple named range and Data Validation to use that Name. If you have not heard of Dynamic Ranges, then you should read on.
If Sheet1 only has the 1 column for the DropDown list via Data Validation, you should use a Named Range instead of a fixed Range. But this named range is dynamic (by using formula)! See OFFSET usage.
Lets say Sheet1 is like below:
Lets say the name to be used is MyList, then in Excel click Name Manager in Formulas tab, and place in below as the Range Refers to:
=OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A:$A))
Now in Sheet2, the Data Validation is placed on B2, when setting it up, once you put in the source to =MyList, Excel highlights it:
Then the drop down list worked:
Now if you add data to your list (Column A on Sheet 1), the MyList automatically expands and hence your DataValidation drop down list!
Note the list will go up to the first blank cell in Column A, so NO GAPS!
Enjoy!
I'm really hoping someone can help me with this one. I have recorded a macro to use within a sheet that needs to create a row at the same position on 2 worksheets and then, on one of them, copy the formula's in the cells from the row below it. The code I have looks like this -
Sub Macro1()
Sheets(Array("SCHEDULE", "ANNUAL SUMMARY")).Select
Sheets("SCHEDULE").Activate
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("ANNUAL SUMMARY").Select
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
Selection.AutoFill Destination:=ActiveCell.Offset(-1, 0).Rows("1:2").EntireRow _
, Type:=xlFillDefault
ActiveCell.Offset(-1, 0).Rows("1:2").EntireRow.Select
Sheets("SCHEDULE").Select
ActiveCell.Select
My problem is, when I run it manually and then record the macro, it does exactly what I want it to, but when I run this from a button on the "SCHEDULE" sheet it does not copy the formula's from the row below the one on the "ANNUAL SUMMARY" sheet.
Can anyone help to get this working with me?
Thanks all in advance
Mark
The problem with the macro recorder is that although it can give you a good indication of what code you need, it also generates very inefficient code and includes all of the select and activate statements that you need to try and avoid using.
Any reference in the code to ActiveCell is referring to the cell that is currently selected and ActiveSheet is the sheet that is currently selected. This can give you undesired results if you run the macro from a different sheet that the macro was recorded from...
If you wanted to copy row 1 from SCHEDULE sheet then you can use
Sheets("SCHEDULE").Rows(1).Copy Sheets("ANNUAL SUMMARY").Rows(1)
If you want to auto fill a range, then this can be accomplished with a single line of code
This will auto fill the contents of row1 (column A - E) down to row 100 in your ANNUAL SUMMARY sheet
Sheets("ANNUAL SUMMARY").Range("A1:E100").FillDown
So if we put it all together and include some declarations for our source and destination sheet to make the sub more readable..
Sub CopyAndFillDownExample()
Dim rowNumber As Long, offset As Long
Dim sourceSht As Worksheet, destinationSht As Worksheet
'set the source and destinationsheets
Set sourceSht = Sheets("SCHEDULE")
Set destinationSht = Sheets("ANNUAL SUMMARY")
'number of rows to copy down
offset = 100
'get currently selected row
rowNumber = ActiveCell.Row
'copy the selected row from the source sheet to the destination sheet
sourceSht.Rows(rowNumber).Copy destinationSht.Rows(rowNumber)
'fill down the formulas
destinationSht.Rows(rowNumber & ":" & rowNumber + offset).FillDown
End Sub
I am trying to create an excel macro which is probably going to end up being quite large, to make things easier I am tackling it a bit at a time. So far I have....
Sub Macro4()
'
' Test Macro
'
'Selects the product_name column by header name
Dim rngAddress As Range
Set rngAddress = Range("A1:Z1").Find("product_name")
If rngAddress Is Nothing Then
MsgBox "The product_name column was not found."
Exit Sub
End If
Range(rngAddress, rngAddress.End(xlDown)).Select
'Inserts new column to the left of the product_name column
Selection.Insert Shift:=xlToRight
'Re-selects the product_name column
Range(rngAddress, rngAddress.End(xlDown)).Select
'Copys the contents of the product_name column
Selection.Copy
Selection.Paste
End Sub
I want it to do the following....
Search the spreadsheet for the header name 'product_name'
Insert a blank column to the left of the 'product_name' column
Copy the contents of the 'product_name' column
Paste them into the newly created blank column
Change the header name in this new column to 'product_name_2'
Currently it works fine up until the pasting into this newly created column, then i get a
'Run-time error '438'; - Object doesn't support this property or method'
Can anyone suggest where i am going wrong?
Your error is:
Range(rngAddress, rngAddress.End(xlDown)).Select
This selects from the top of the column down to just above the first blank cell. The insert shifts this portion of the column right leaving the rest where it is. When you select again you are likely to get a larger range because you have mixed two columns. The copy fails because you are then trying to copy values over the top of values.
If that does not make sense, step through your macro with F8 and see what is happening at each step.
When you understand why your current macro does not work, try this:
Sub Macro5()
Dim rngAddress As Range
Dim ColToBeCopied As Integer
Set rngAddress = Range("A1:Z1").Find("'product_name")
If rngAddress Is Nothing Then
MsgBox "The product_name column was not found."
Exit Sub
End If
ColToBeCopied = rngAddress.Column
Columns(ColToBeCopied).EntireColumn.Insert
Columns(ColToBeCopied + 1).Copy Destination:=Columns(ColToBeCopied)
End Sub
Note:
I did not select anything.
I have left the code operating on the active sheet but it is better to use With Sheets("XXX") ... End With.
Answer to second question
The macro recorder is not good at showing how to address individual cells systematically.
With Sheets("xxxx")
.Cells(RowNum,ColNum).Value = "product_name 1"
End With
The above uses With which I recommend. Notice the dot in front of Cells.
The one below operates on the active sheet.
Cells(RowNum,ColNum).Value = "product_name 1"
RowNum must be a number. ColNum can be a number (say 5) or a letter (say "E").
In your case RowNum is 1 and ColNum is ColToBeCopied and ColToBeCopied + 1.
P.S.
I forgot to mention that to find the botton row of a column use:
RowLast = Range(Rows.Count, ColNum).End(xlUp).Row
That is move up from the bottom not down from the top.
P.S. 2
To specify a range using Cells:
.Range(.Cells(Top,Left),.Cells(Bottom,Right))
The dots must match: all three or none.
I'm not sure where you are trying to copy to,
but when you want to paste you need to make a selection and then
ActiveSheet.Paste
For example:
/your code/
Selection.Copy
Range("O:O").Select
ActiveSheet.Paste
I would avoid copying / pasting altogether, if you only want to transfer values.
For example, instead of:
Range("B1:B100").Copy Destination:=Range("A1")
I would use:
Range("A1:A100").Value = Range("B1:B100").Value
If we were to substitute that into your code, and include some of the comments made by Tony:
Sub Macro4()
Dim colFound As Integer
Dim rowLast As Long
Const rowSearch As Integer = 1
'Find the product_name column
colFound = Rows(rowSearch).Find("product_name").Column
If colFound = 0 Then
MsgBox "The product_name column was not found."
Exit Sub
End If
'Find the last non-empty row
rowLast = Cells(Rows.Count, colFound).End(xlUp).Row
'Inserts new column to the left of the product_name column
Columns(colFound).EntireColumn.Insert
'Transfer the contents of the product_name column to the newly inserted one
Range(Cells(rowSearch, colFound), Cells(rowLast, colFound)).Value = _
Range(Cells(rowSearch, colFound + 1), Cells(rowLast, colFound + 1)).Value
'Rename the new column
Cells(rowSearch, colFound).Value = Cells(rowSearch, colFound).Value & "_2"
End Sub