I've been creating a VBA code to help me with a worksheet I use but I'm stuck at a certain point.
The code looks at the table on the current worksheet, adds a new column to the end of the table and then I get it to copy the first column in the worksheet (as this has the formats and some calculated cells). This is where my coding finishes. Ideally I would then like it to take the copied cells and paste them into the new end column of the table.
This is what I have so far:
Sub AddNewColumn()
Application.ScreenUpdating = False
Dim oSh As Worksheet
Set oSh = ActiveSheet
With oSh.ListObjects("Labour")
.ListColumns.Add
Range("Labour[[#All],[Column16]]").Select
Selection.Copy
End With
Application.ScreenUpdating = True
End Sub
(Labour being the name of the current table).
If I can get this to work fantastic but then I think I will encounter another issue. The table is on a template worksheet and contained on this I have a command button to create a copy of the template (for different tasks). This would then change the name of the table (Labour1 then Labour2 etc as new worksheets are created). How would I get the code to work on new worksheets as the code I have at the minute would simply want to link back to the original table (Labour).
You don't need actually copy values from the first column to the newly created, just use formula. I have modified your code:
Sub AddNewColumn()
Application.ScreenUpdating = False
Dim oSh As Worksheet
Dim oList As ListObject
Dim str As String
Set oSh = ActiveSheet
Set oList = oSh.ListObjects("Labour")
With oList
.ListColumns.Add
str = .ListColumns(1).Name
.ListColumns(.ListColumns.Count).DataBodyRange.FormulaR1C1 = "=[#[" & str & "]]"
End With
End Sub
If you need actual values, not formulas, you may copy and paste special the last column. Before end with add:
With .ListColumns(.ListColumns.Count).DataBodyRange
.Copy
.PasteSpecial xlPasteValues
End With
This is answer to your first question. Unfortunately, I am not able to understand the second. Besides, I think you should ask it separately.
OK I have tweaked your code #MarcinSzaleniec and it appears to be working.
Sub AddNewColumn()
Application.ScreenUpdating = False
Dim oSh As Worksheet
Dim oList As ListObject
Dim str As String
Set oSh = ActiveSheet
Set oList = oSh.ListObjects("Labour")
With oList
.ListColumns.Add
str = .ListColumns(1).Name
Range("Labour[[#All],[Column16]]").Select
Selection.Copy
.ListColumns(.ListColumns.Count).DataBodyRange.PasteSpecial xlPasteAll
Application.ScreenUpdating = True
End With
End Sub
The reason I need:
Range("Labour[[#All],[Column16]]").Select
Selection.Copy
Is due to it being a column hidden out the way and has the blank bits blank and the formula bits as formulas.
Many thanks for everybody's help. Now to ask the second part of my question on here.
Related
Second part of a question which has been answered on here
First Part Of Question
I have a worksheet that contains a table that has some code to add columns as and when needed. This works perfectly (thanks to answers on this site) but within the code it references the table name (in this case it is a table called 'Labour'). The worksheet is also a blank template that again has some code that copies the entire worksheet and pastes it to the end of the workbook for the next new task.
The problem I have now is that as I have a table on the template worksheet, when the worksheet is copied to a new worksheet the table name changes (ie if it was table1 it is then named table2 on the new sheet). This in turn stops the code working for adding a new column into the new table. Is there anyway to have the code 'know' what table is on the sheet and use that?
I can get the table name to appear in a cell, would there be a way to use that?
The code for adding a column to the table is:
Sub AddNewColumn()
Application.ScreenUpdating = False
Dim oSh As Worksheet
Dim oList As ListObject
Dim str As String
Set oSh = ActiveSheet
Set oList = oSh.ListObjects("Labour")
With oList
.ListColumns.Add
str = .ListColumns(1).Name
Range("Labour[[#All],[Column16]]").Select
Selection.Copy
.ListColumns(.ListColumns.Count).DataBodyRange.PasteSpecial xlPasteAll
Application.ScreenUpdating = True
End With
End Sub
As you can see the table name "Labour" is within the code
Set oList = oSh.ListObjects("Labour")
So when adding a new column on the new worksheet I get an error (because the table Labour doesn't exist on the new sheet).
Scrap this question I think I have figured it out. I got VBA to use the cell with the table name in so it could use a variable. Code as follows:
Sub AddNewColumn()
Application.ScreenUpdating = False
Dim oSh As Worksheet
Dim oList As ListObject
Dim tblName As String
Dim str As String
tblName = Range("B18").Text
Set oSh = ActiveSheet
Set oList = oSh.ListObjects(tblName)
With oList
.ListColumns.Add
str = .ListColumns(1).Name
Range(tblName & "[[#All],[Column16]]").Select
Selection.Copy
.ListColumns(.ListColumns.Count).DataBodyRange.PasteSpecial xlPasteAll
Application.ScreenUpdating = True
End With
End Sub
I've left this just in case it could help anyone else.
I've recently discovered VBA code to filter slicers based off of variable names. It is a great tool for filtering what you want to see
The next step in my code is to potentially REMOVE visible data from my pivot table/chart (automatically).
Lets say I already have a variable "Remove_ITEM" that needs to be removed from the data shown. Remove_item is inside slicer ("slicer_Order").
The data is also inside a data model.
The code below is to ONLY show REmove_Item:
ActiveWorkbook.SlicerCaches("Slicer_Order").'VisibleSlicerItemsList = ("[Actuals_Table].[Order].&["& Remove_item &"]")
Now i want to do the opposite
I hope I understood what you are trying to achieve in your post.
Try the code below and let me know if it works as you intended:
Option Explicit
Sub SlicersTst()
Dim WB As Workbook
Dim OrderSlcrCache As SlicerCache
Dim OrderSlcItem As SlicerItem
Dim RemoveItem As Variant
Set WB = ThisWorkbook
Set OrderSlcrCache = WB.SlicerCaches("Slicer_Order") '<-- set Slicer Cache to "Order" slicer
OrderSlcrCache.ClearManualFilter '<-- clear manual filters
RemoveItem = "c" '<-- set value for test
' loop through all slicer items in slicer "Order"
For Each OrderSlcItem In OrderSlcrCache.SlicerItems
If OrderSlcItem.Name = RemoveItem Then OrderSlcItem.Selected = False
Next OrderSlcItem
End Sub
Please keep in mind this is specifically for data model usage with a connection.
Sub Variables()
Part_Number = Worksheets("Solumina_Data_Page").Cells(Row, "B").Value
End Sub
Sub Sort_Part_Number()
Application.ScreenUpdating = False
Page1 = ActiveSheet.Name
Call Variables
Sheets("Dashboard").Activate
ActiveWorkbook.SlicerCaches("Slicer_Material").VisibleSlicerItemsList = "[Part List].[Material].&[" & Part_Number & "]"
' "[Part List].[Material].&[77C726210G1]" <<What we want to see
Sheets(Page1).Activate
Application.ScreenUpdating = True
End Sub
Heres a similar example using the array
Sub Use_ARRAY()
Dim ARR() As String
ReDim ARR(1 To 2)
Call Array_Actuals_Data 'get data
Call Array_Outliers_removed 'sort data
ARR(1) = "[Actuals_Table].[Order].&[000010840921]"
ARR(2) = "[Actuals_Table].[Order].&[000010949159]"
ActiveWorkbook.SlicerCaches("Slicer_order").VisibleSlicerItemsList = ARR()
End Sub
I was able to copy the rows to another workbook by using predefined ranges. However, I wanted to make sure that it only needs to copy those with values. I've been formulating this code but it returns an error -1004
Private Sub test()
Dim WBa As Workbook, MyPathA As String
Dim FinalRow As Long
Dim getDBsht As Worksheet
MyPathA = "sharepoint.com/Financial Tracker v8.xlsx"
ThisWorkbook.Sheets("ConTracker_DB").UsedRange.ClearContents
' Attempt to open a sharepoint file
Set WBa = Workbooks.Open(MyPathA)
'Set WBb = Workbooks.Open(MyPathB)
Set getDBsht = WBa.Sheets("ConTracker_DB")
getDBsht.UsedRange.Copy
'error starts here
ThisWorkbook.Sheets("ConTracker_DB").UsedRange.Paste
Application.CutCopyMode = False
WBa.Close
Set WBa = Nothing
End Sub
UPDATED CODE: UsedRange fixed my copy rows with value only, but pasting error still persists
You could iterate the individual cells and copy only those which have a value:
Dim sourceCell as Range
Dim targetCell as Range
Set targetCell = ThisWorkbook.Sheets("ConTracker_DB").Range("A1").
For each sourceCell in Range("theNamedRangeYouWantToCopyFrom")
'I'm not sure if you need a dynamic range to copy from, but if you don't...
'...it's much easier to use a "named range" for that.
If sourceCell.Value <> "" Then
targetCell.Value = sourceCell.Value
Set targetCell = targetCell.Offset(1,0)
End If
Next sourceCell
Try defining the final column you need copied and then defining the start and end cells in the range:
FinalCol = 23 '(or whatever you need)
getDBsht.Range(getDBsht.Cells(1, 1), getDBsht.Cells(FinalRow, FinalCol)).Copy
Also note that above I'm specifying which worksheet the cells in the range come from. This can help if you have multiple workbooks/worksheets open at once.
Defining the destination before you start copying is a good idea, too.
CopyTo = ThisWorkbook.Sheets("ConTracker_DB").Range("A1")
Answering my question :))
Basically if you're using usedRange.Copy
you should be pasting with
Cells(1, 1).PasteSpecial Paste:=xlPasteValues
Please find below for the complete code if you're using this:
Private Sub test()
Dim WBa As Workbook, MyPathA As String
Dim FinalRow As Long
Dim getDBsht As Worksheet
MyPathA = "sharepoint.com/Financial Tracker v8.xlsx"
ThisWorkbook.Sheets("ConTracker_DB").UsedRange.ClearContents
' Attempt to open a sharepoint file
Set WBa = Workbooks.Open(MyPathA)
'Set WBb = Workbooks.Open(MyPathB)
Set getDBsht = WBa.Sheets("ConTracker_DB")
getDBsht.UsedRange.Copy
ThisWorkbook.Sheets("ConTracker_DB").Cells(1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
WBa.Close
Set WBa = Nothing
End Sub
I am very new to VBA and there is a task I would like to automate and don't know where to start. I have a data set that looks like below.
Sample Data
What I'm trying to do is loop through column A and if it has something in it (will always be an email) select all rows until there is something in column A again. Copy and paste into new tab. So row 2-5 would copy and paste into a new tab. Then row 6-9 into a different new tab. Also row 1 would copy to each tab as well. I haven't been able to find code to help with this specific need and any help would be greatly appreciated.
I found this code and started modifying it but, it's nowhere close to what I need or working for that matter.
Sub split()
Dim rng As Range
Dim row As Range
Set rng = Range("A:A")
For Each row In rng
'test if cell is empty
If row.Value <> "" Then
'write to adjacent cell
row.Select
row.Copy
Worksheets("Sheet2").Activate
Range("A2").Select
row.PasteSpecial
Worksheets("Sheet1").Activate
End If
Next
End Sub
This code should provide what you need:
Sub Split()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Worksheets(1) 'change sheet index or use Worksheets("Sheet1") method to use exact name
Dim rngBegin As Range
Dim rngEnd As Range
With ws
Dim rngHeader As Range
Set rngHeader = .Range("A1:H1") 'to copy headers over each time
Dim lRowFinal As Long
lRowFinal = .Range("C" & .Rows.Count).End(xlUp).Row 'assumes eventually last row of needed data will have an address1
Set rngEnd = .Range("A1") ' to begin loop
Set rngBegin = rngEnd.End(xlDown) 'to begin loop
Do
Set rngEnd = rngBegin.End(xlDown).Offset(-1)
Dim wsNew As Worksheet
Set wsNew = Worksheets.Add(After:=wb.Sheets(.Index))'always after current sheet, change as needed
.Range(.Cells(rngBegin.Row, 1), .Cells(rngEnd.Row, 8)).Copy wsNew.Range("A2")
wsNew.Range("A1:H1").Value = rngHeader.Value
Set rngBegin = rngEnd.End(xlDown)
Loop Until rngBegin.Row >= lRowFinal
End With
End Sub
Try to break your process into steps and determine rules on how to proceed. Then write out some pseudo-code (code like logic) to make sure it all makes sense.
You need some sort of loop, since you are going to treat each
group of rows in the same way.
You need some code that determines what cells are contained in each block
Code to take a block (given by step 2) and paste it into a new tab.
Your Pseudo Code might look like this:
' This is the main function that runs the whole routine
Sub Main()
Set headerRg = GetHeaderRg()
Do Until IsAtTheEnd(startRow) = True
Set oneBlock = GetNextBlock(startRow)
Call ProcessBlock(oneBlock)
startRow = startRow + oneBlock.Rows.Count
Loop
End Sub
' This function returns the header range to insert into the top
Function GetHeaderRg() As Range
' Write some code here that returns the header range
End Function
' This function determines whether we are at the end of our data
Function IsAtTheEnd(current_row as Long) as Boolean
' Write some code here that determines whether we have hit the end of our data
'(probably checks the first column to see if there is data)
End Function
' This function takes the startRow of a block and returns the whole block of Rows
Function GetNextBlock(startRow) As Range
' Write some code that returns the whole range you want to copy
End Function
' This sub takes a range to be processed and a header to print and prints
' it into a new tab
Sub ProcessBlock(BlockRg As Range, headerRg as Range)
Set targetSheet = thisWorkbook.Sheets.Add()
' Write some code that pastes the headerRg and BlockRg where you want it
End Sub
If you start to have more specific questions about syntax etc, we will be happy to help here!
My overall project is to have a sheet that acts as an array/repository for values to be referenced, and to provide this as part of a macro for others to use. I have other code that references this array, and in the setup macro I have a check if this sheet already exists:
Sub Detailed_Report_SS_Setup()
Application.DisplayAlerts = False
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets("Array")
On Error GoTo 0
If Not ws Is Nothing Then
Else
Sheets.Add().Name = "Array"
Populate_Array_Sheet
End If
Application.DisplayAlerts = True
End Sub
In trying to make the Populate_Array_Sheet, I attempted to manipulate some existing code I used to name sheets in a workbook. My issue is that excel is looping through my array and adding each value to every row of the column, overwriting values as it goes through the array.
I believe my issue is the bounds (i use lower and upper), though I don't know enough about this to figure out how to correct. Here is my example of the problematic code:
Sub Populate_Array_Sheet()
Dim i As Long
Dim Arf As Variant
Arf = Array("n1", "n2", "n3", ..., "n36")
For i = LBound(Arf) To UBound(Arf)
Sheets("Array").Range("A1:A36") = Arf(i)
Next i
End Sub
I'm trying to get each individual value (n1 through n36) onto its own row in the column.
you are using Range("A1:A36") you are applying the value to entire range Try this
Sub Populate_Array_Sheet()
Dim i As Long
Dim Arf As Variant
Arf = Array("n1", "n2", "n3",....., "n36")
Sheets("Array").Range("A1").Activate
For i = LBound(Arf) To UBound(Arf)
ActiveCell.Value = Arf(i)
ActiveCell.Offset(1, 0).Activate
Next i
End Sub