I have 3 named table : Table11, Table34, Table41.
The idea is that, any time I am inserting/adding a new table(lets say Table56), in the new table I need to add the data from previous inserted added table data: the values from columns Tax1, Tax2, Fees.
Sometimes the table might have additional columns and rows, which it shouldn't affect retrieving data from a previous table into a new table. Also, it might happen that the name of tables to be different, because the file is accessed by different users
The name of the table is added as a list in another worksheet when the table is created, for this I was able to create a small code using a template table (copy and paste).
So, is it possible to retrieve data in last named table from previous inserted named table?
Anyone can give me a helpful hand?
Update New Table With Data From Previously Added Table
Sub UpdateNewTable()
' Define constants.
Const wsName As String = "Report"
Const CriteriaHeader As String = "ID"
Const sTableHeadersList As String _
= "Wage,Tax1,Tax2,Fees"
Const dTableHeadersList As String _
= "Wage Previous,Tax1 Previous,Tax2 Previous,Fees Previous"
' Reference the objects.
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim tblCount As Long: tblCount = ws.ListObjects.Count
If tblCount < 2 Then Exit Sub
Dim stbl As ListObject: Set stbl = ws.ListObjects(tblCount - 1)
Dim dtbl As ListObject: Set dtbl = ws.ListObjects(tblCount)
Dim srg As Range: Set srg = stbl.ListColumns(CriteriaHeader).DataBodyRange
Dim drg As Range: Set drg = dtbl.ListColumns(CriteriaHeader).DataBodyRange
' Read data.
' A 2D one-based one-column array with the same number of rows
' as the source (one-column) range, holding the destination (table)
' row indexes where the source values were found.
' There will be error values for not found values ('IsNumeric').
Dim drIndexes As Variant: drIndexes = Application.Match(srg, drg, 0)
Dim sHeaders() As String: sHeaders = Split(sTableHeadersList, ",")
Dim dHeaders() As String: dHeaders = Split(dTableHeadersList, ",")
Dim hUpper As Long: hUpper = UBound(sHeaders)
' Write (copy) data.
Dim sr As Long
Dim dr As Long
Dim hc As Long
For sr = 1 To UBound(drIndexes) ' or '1 To srg.Rows.Count'
If IsNumeric(drIndexes(sr, 1)) Then
dr = drIndexes(sr, 1)
For hc = 0 To hUpper
dtbl.ListColumns(dHeaders(hc)).DataBodyRange.Rows(dr).Value _
= stbl.ListColumns(sHeaders(hc)) _
.DataBodyRange.Rows(sr).Value
Next hc
End If
Next sr
' Inform.
MsgBox "New table updated.", vbInformation
End Sub
Related
I am trying to pass a range of columns as a parameter for a function.
For sr = 1 To srCount
If IsEmpty(Data(sr, 4)) Then
dr = dr + 1
Data(dr, 4) = Data(sr, 1) 'instead of just the first column, a range of columns
End If
Next sr
I thought I could define a range ("A:C") and pass its reference as a parameter, but VBA doesn't seem to accept anything but (references to) long variables/constants as parameters for the Data() function. What is the correct syntax for such a thing?
Edited 01/26 for clarification: Data is an array. The goal is to copy a row of a range of columns based on the condition that another cell in that row is empty (If IsEmpty(Data(sr, 4))). E.g. if cell(7,4) is empty, then row 7 of columns A-C should be copied to another area of the worksheet (K2:M2). If (13,4) is empty, then row 13, columns A-C to K3-M3, and so on.
As per #Cameron's tip I used Collections to store the ranges instead.
Dim users As New Collection
Dim cell As Range
With Worksheets(2)
users.Add .Range("A:C"), "Users"
users.Add .Range("K:M"), "FinalList"
End With
For Each cell In users.Item("Users")
For sr = 1 to srCount
If IsEmpty(Data(sr, 4)) Then
dr = dr + 1
FinalList = Users
End If
Next sr
Next
Despite the research I can't find how I can manipulate Collections for this objective. Once I have all the necessary values stored in FinalList, how can I copy them to the goal Range ("K:M")?
Using a Single Array to Extract Matching Data
Option Explicit
Sub Test()
Const SRC_CRITERIA_COLUMN As Long = 4
Const DST_WORKSHEET_ID As Variant = 2 ' using the tab name is preferable!
Const DST_FIRST_CELL As String = "K2"
' The following could be calculated from the source variables.
Const DST_COLUMNS_COUNT As Long = 3
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' whatever...
Dim Data() ' ?
Dim srCount As Long ' ?
' whatever...
Dim sr As Long, dr As Long, c As Long
' Write the matching values to the top of the array
' When using a single array, the result needs to be in the top-left
' of the array. The data of interest is already left-most
' so there is no column offset.
For sr = 1 To srCount
If IsEmpty(Data(sr, SRC_CRITERIA_COLUMN)) Then
dr = dr + 1
For c = 1 To DST_COLUMNS_COUNT
Data(dr, c) = Data(sr, c)
Next c
End If
Next sr
' Reference the destination range.
Dim dws As Worksheet: Set dws = wb.Worksheets(DST_WORKSHEET_ID)
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
' Note how you're using just the 'dr' number of rows
' and 'DST_COLUMNS_COUNT' number of columns.
Dim drg As Range: Set drg = dfCell.Resize(dr, DST_COLUMNS_COUNT)
' Write the result from the top-left of the array to the destination range.
drg.Value = Data
' Clear below.
drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).ClearContents
MsgBox "Data copied.", vbInformation
End Sub
I have 25 spreadsheets that have pie charts.
I need to loop through the spreadsheets and change where the pie charts get the information from. But I can't get the code to work. I am coming from this:
Sub ChangePieValues()
Dim sheetno As Integer
sheetno = 14
Sheets(sheetno).Activate
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.FullSeriesCollection(1).XValues = "=Worksheets(2)$BA$3:$BA$6"
ActiveChart.FullSeriesCollection(1).Values = "=Worksheets(2)$BB$3:$BB$6"
End Sub
I haven't added the loop yet as this is the easy part.
My problem is in the following line:
ActiveChart.FullSeriesCollection(1).XValues = "=Worksheets(2)$BA$3:$BA$6"
I thought I could write something like:
ActiveChart.FullSeriesCollection(1).XValues = "=Worksheets(2).((Range(55,3)):(Range(55,6))"
I am trying to change the Range of the XValues to a number so I can change that number as I go through the different spreadsheets.
How can I change the way I input the column index, so it can be changed by loops.
Based on your question and example code - where you're providing a String to Excel that refers to the range - I would suggest the following solution:
ActiveChart.FullSeriesCollection(1).XValues = _
"'" & Worksheets(2).Name & "'!" & Cells(3, 53).Address & ":" & Cells(6, 53).Address
However, a better way would be to provide the property with a Range object (instead of a string that refers to the range object). This should also work, like so:
ActiveChart.FullSeriesCollection(1).XValues = _
Worksheets(2).Range(Worksheets(2).Cells(3, 53), Worksheets(2).Cells(6, 53))
To make that tidier to read though, I'd use:
With Worksheets(2)
ActiveChart.FullSeriesCollection(1).XValues = _
.Range(.Cells(3, 53), .Cells(6, 53))
End With
You were very close to achieving this in your example attempts, but as you were wrapping the location in double-quotes - Excel took them as if a String referencing a Range.
VBA ChartObjects: Change Source Data (SetSourceData)
In the workbook containing this code (ThisWorkbook), this will change the source data in the charts named Chart 1 of 25 consecutive worksheets, starting with the 14th worksheet, to the values in 25 consecutive columns in the 2nd worksheet, starting with column BA3:BA6.
Sub ChangeSourceData()
' Define constants.
' Source
Const sId As Variant = 2 ' name or index ('As Variant')
Const sFirstColumnAddress As String = "BA3:BA6"
' The number of source columns ('scCount') is equal
' to the number of destination worksheets.
Const scCount As Long = 25
' Destination
Const dFirstIndex As Long = 14 ' First Destination Worksheet
Const dChartName As String = "Chart 1" ' Each Worksheet's Chart Name
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(sId)
Dim srg As Range: Set srg = sws.Range(sFirstColumnAddress).Resize(, scCount)
' Declare additional variables.
' Source
Dim sc As Long
' Destination
Dim dws As Worksheet
Dim dch As Chart
Dim dcho As ChartObject
Dim dIndex As Long
' Loop and apply.
' Loop through the columns ('sc') of the source range, indirectly...
For sc = 1 To scCount
' ... looping through the destination worksheets ('dIndex').
dIndex = dFirstIndex + sc - 1
' Reference the destination worksheet ('dws') by index,...
Set dws = wb.Worksheets(dIndex)
' ... to reference its 'ChartObject' ('dcho') by name ...
Set dcho = dws.ChartObjects(dChartName)
' ... to reference its 'Chart' ('dch') avoiding 'Activate'.
Set dch = dcho.Chart
' Set the new (one-column) data range for the chart.
dch.SetSourceData srg.Columns(sc)
'dch.FullSeriesCollection(1).ApplyDataLabels
Next sc
' Inform.
MsgBox "Source data changed.", vbInformation
End Sub
I’m currently having an issue which I don’t think i can resolve.
I have a table in excel with multiple titles such as “Promoter”, “Account”, “#order”, “Date” & “City” with thousands of rows in it.
I just want to know if there is a VBA code to delete specific rows with duplicated values if those were to appear in 2 columns (A and B)
Such as if the “Account” and the “Promoter” are the same in many other rows, i just want to delete the duplicates and leave one for accounting purposes.
Example:
Data
0987:Raymond:ORD-27:NY
1256:Hannah :ORD-99:MI
1345:André :ORD-45:WI
1866:Darryl :ORD-02:WA
6419:John. :ORD-22:CA
0987:Raymond:ORD-87:MN
0987:Raymond:ORD-24:CO
Result:
1256:Hannah :ORD-99:MI
1345:André :ORD-45:WI
1866:Darryl :ORD-02:WA
6419:John. :ORD-22:CA
0987:Raymond:ORD-87:MN
Because the “account” (09087) and the “Promoter” (Raymond) are repeated in the rows below even though the order and the state are different, i just want to delete the duplicates that fall in that category (Same account and Promoter) and keep one because the orders belong to the same account. There are several “promoters” to consider, that’s why I don’t know how to proceed.
Thank you very much for your help i will appreciate every answer.
Keep Unique (Two Columns)
Adjust the values in the constants section.
The Code
Option Explicit
Sub keepUniqueTwoColumns()
Const wsName As String = "Sheet1"
Const First As Long = 2
Const ColLR As String = "A"
Const Col1 As String = "A"
Const Col2 As String = "B"
Const Delimiter As String = "|"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim Last As Long: Last = ws.Cells(ws.Rows.Count, ColLR).End(xlUp).Row
Dim rg1 As Range: Set rg1 = ws.Cells(First, Col1).Resize(Last - First + 1)
Dim rg2 As Range: Set rg2 = ws.Cells(First, Col2).Resize(Last - First + 1)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim drg As Range
Dim cel As Range
Dim Key As Variant
Dim i As Long
For Each cel In rg1.Cells
i = i + 1
Key = rg1.Cells(i) & Delimiter & rg2.Cells(i)
If dict.Exists(Key) Then
If drg Is Nothing Then
Set drg = rg1.Cells(i)
Else
Set drg = Union(drg, rg1.Cells(i))
End If
Else
dict.Add Key, Empty
End If
Next cel
Set dict = Nothing
If drg Is Nothing Then
MsgBox "Nothing deleted.", vbExclamation, "Fail"
Else
Dim dCount As Long: dCount = drg.Cells.Count
drg.EntireRow.Delete
MsgBox "Deleted rows: " & dCount, vbInformation, "Success"
End If
End Sub
I am trying to create a VBA module, that takes data from a table in one worksheet and copies it to a second worksheet. This second worksheet should then be exported as a PDF.
The exporting part and naming the PDF is not an issue and I will only tackle this when the copying of the data from one sheet to the other works.
The structure of the table is that I have several rows that have data relevant to the invoice I want to fill on the second sheet and I would like that the macro loops through the whole file and only takes what it needs, but for now I am working on an easier version where I simply want to copy the data from a selection.
Option Explicit
Sub InvoiceCreator()
'create sheet
'Add info to sheet'
'save invoice sheet as PDF with name of customer
'reset sheet
'insert i+1 dataset
'loop til end
Dim sWS As Worksheet
Dim dWS As Worksheet
Dim sRange As Range
Dim sBNR As Range
Dim dBNR As Range
Dim sKNR As Range
Dim dKNR As Range
Dim sREF As Range
Dim dREF As Range
Dim sPRT As Range
Dim dPRT As Range
Dim sDAT As Range
Dim dDAT As Range
Dim sADR As Range
Dim dADR As Range
Dim sDES As String
Dim dDES As String
'Dim sPRC As Range
'Dim dPRC As Range
Dim i As Integer
Dim lastrow As Long
Set sWS = Sheets("Data")
Set dWS = Sheets("Sheet1")
Set sRange = Selection
Set sBNR = sRange.Cells(2, 7)
Set dBNR = dWS.Range("E4")
dBNR = sBNR.Value
Set sKNR = sRange.Cells(2, 2)
Set dKNR = dWS.Range("E6")
dKNR = sKNR.Value
Set sREF = sRange.Cells(2, 22)
Set dREF = dWS.Range("E8")
dREF = sREF.Value
Set sPRT = sRange.Cells(2, 23)
Set dPRT = dWS.Range("E10")
dPRT = sPRT.Value
Set sDAT = sRange.Cells(2, 4)
Set dDAT = dWS.Range("F4")
dDAT = sDAT.Value
lastrow = sRange.End(xlUp).Row
For i = 2 To lastrow
sDES = sRange.Cells(i, 12)
dDES = dWS.Range("A" & i + 23)
dDES = sDES
Next i
End Sub
Most of the code works and copies values from one sheet to the other, but I am stuck with the last loop bit.
I want to take the value of the string in a cell and copy it to a cell in the other sheet and then copy the cell value of the cell below and copy it to the other worksheet one cell below until the end of my selection. I am not getting any error, but it is not copying the data.
Any advice?
I have an issue that has been bugging me on and off for the last few days.
I have a worksheet with 100's of tables on, and a code that will insert more data onto that worksheet as it runs.
The idea is to then convert that added data to tables. However I run into a few problems with this.
I shall try and explain my current method, I have a for loop that can easily select the data in each of the current tables and the new data that has been added, using the .find method based upon i being Odd or Even. I then run down the spearsheet (as all the data is in the same column.) At this point I run into a world of trouble.
Firstly I tried to select the range of data that should be a table ( Sometimes it is, other it's not) and convert to table. This didnt work as I found out you are unable to force a table to become the same table again.
Secondly I tried to use On Errors to get around this. I tried to unlist the range as a table, then if there was an error i.e. the range was not a table then goto the section that makes the range a table, and if the Selected range was a table to then remove the table from the range and the re-format the range as a table.
At this point I was out of ideas. Below is my code for my second attempt.
If i Mod 2 = 0 Then ' This is to select the New Range '
j = j + 1 ' Used to name the tabels '
Set TableRange = Range(Cells(StartRow, 6), Cells(EndRow - 1, 13)) ' Selectst the table range '
TableRange.Select ' Selects the tabels '
On Error GoTo AddTable:
ActiveSheet.ListOnjects.Items(1).Unlist
AddTable:
ActiveSheet.ListObjects.Add(xlSrcRange, TableRange, , xlYes).Name = "Table" & j ' Formats the selected range as a table and names the table '
Range("Table" & j & "[#All]").Select ' Selects the table '
ActiveSheet.ListObjects("Table" & j).TableStyle = "TableStyleLight15" ' Sets the table style '
End If
I have tried to comment the code as best as possible as well as giving you a background into what my thought process was. I expect there are far simpler ways to do this, but not that I can think off.
Thanks for any help you can provide
Here is an example where ws.Range("A1:C8") is a table (the entire table including headers). Uses a function to return True if table else False
Option Explicit
Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Dim testRange As Range
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
Set testRange = ws.Range("A1:C8")
If IsTable(testRange, ws) Then
Debug.Print "Table"
Else
End If
End Sub
Public Function IsTable(ByVal testRange As Range, ByVal ws As Worksheet) As Boolean
Dim table As ListObject
Dim tableAddresses() As String
ReDim tableAddresses(ws.ListObjects.Count)
Dim counter As Long
For Each table In ws.ListObjects
tableAddresses(counter) = table.Range.Address 'or databody range depending on your requirements
counter = counter + 1
Next table
Dim i As Long
For i = LBound(tableAddresses) To UBound(tableAddresses)
If testRange.Address = tableAddresses(i) Then
IsTable = True
Exit Function
End If
Next i
End Function
New data can be added to a ListObject using any of these two options:
Posting the new data in the next row immediately after the last row of the ListObject. The ListObject automatically resizes to include the new rows.
Resizing the Range of the ListObject to include the new rows. Note that when resizing a ListObject the Header must remain in the same row.
To validate if any Cell in a Range is part of a ListObject use the ListObject property of the range:
Set lo = rg.ListObject
I would also suggest declaring the variables and the use of Objects, so lines like this: ActiveSheet.ListOnjects.Items(1).Unlist would be written as: ws.ListOnjects.Items(1).Unlist. Then when compiling or running the procedures, spelling errors will be highlighted, given you the opportunity to do corrections such as: ws.ListObjects(1).Unlist. To force the declaration of variables and syntax check see fig. below.
As regards the Style of the ListObject you can set it by default for a workbook using this line:
wb.DefaultTableStyle = "TableStyleLight15" 'where wb is the workbook object
or it can be set when adding the ListObject as in:
ws.ListObjects.Add(xlSrcRange, rg, , xlYes, , "TableStyleLight15")
Try this procedure:
Sub Range_ListObject_Resizing()
Dim ws As Worksheet, rg As Range, lo As ListObject
Dim lRowIni As Long, lRowEnd As Long, i As Integer
Set ws = ActiveSheet
ws.Parent.DefaultTableStyle = "TableStyleLight15"
lRowIni = 3 'change as required
lRowEnd = 20 'change as required
If i Mod 2 = 0 Then
Rem Set Objects
Set rg = ws.Range(Cells(lRowIni, 6), Cells(lRowEnd - 1, 13))
Set lo = rg.ListObject
Rem Validate ListObject
If Not (lo Is Nothing) Then
lo.Resize rg
lo.TableStyle = "TableStyleLight15"
Else
Set lo = ws.ListObjects.Add(xlSrcRange, rg, , xlYes)
End If: End If
End Sub