I want to resize a chart table in PowerPoint via VBA. I've read the following solution multiple times (Resize Listobject Table dynamically with VBA) and it does seem precisely what I need, but for some reason (maybe because I'm running the macro from PowerPoint) it gives me the following error: Automation error (Error 440).
I plan to use the Resize method because I'm updating a PPT chart data table from another Excel file without using the .Activate method (I opted to not use the .Activate because it opened many charts workbooks after the Macro finished execution, even with multiple Waits and Excel.Application.Quit and .Close).
It works great, the charts workbooks do not flash on the screen and the values are copied fast, BUT... the table size is not correct. It only includes the 1st line of the ppt chart data table, and thus my chart is rendered incomplete.
Dim Line As Range Dim financialPartner As String, financialProject As String
financialPartner = excl.Workbooks("HNK-Status-CDAU.xlsx").Sheets("Financial").Cells(int_lin, 2)
financialProject = excl.Workbooks("HNK-Status-CDAU.xlsx").Sheets("Financial").Cells(int_lin, 3)
Dim found As Boolean
found = False
Dim lastRow As Long
Dim financialChart As Chart
Dim financialChartData As Range
Dim financialChartTable As ListObject
Dim financialChartTablews As Worksheet
lastRow = ActiveWindow.Selection.SlideRange.Shapes("RevenuesVolume").Chart.chartData.Workbook.Sheets(1).Range("A1048576").End(xlUp).Row
Set financialChart = ActiveWindow.Selection.SlideRange.Shapes("RevenuesVolume").Chart
Set financialChartTablews = ActiveWindow.Selection.SlideRange.Shapes("RevenuesVolume").Chart.chartData.Workbook.Worksheets(1)
Set financialChartTable = financialChartTablews.ListObjects("Tabela1")
For Each Line In chartDataTable.DataBodyRange.Rows
Dim lineNumber As Long
lineNumber = Line.Row
If ((Line.Columns(1) <> financialPartner) Or (Line.Columns(2) <> financialProject)) And found Then
Exit For
End If
If (Line.Columns(1) = financialPartner) And (Line.Columns(2) = financialProject) Then
found = True
With financialChart.chartData
Set financialChartData = .Workbook.Worksheets(1).ListObjects(1).Range
financialChartData.Range("A" & lastRow).Value = chartDataWs.Cells(lineNumber, 4)
financialChartData.Range("B" & lastRow).Value = chartDataWs.Cells(lineNumber, 5)
financialChartData.Range("C" & lastRow).Value = chartDataWs.Cells(lineNumber, 6)
lastRow = lastRow + 1
financialChartTable.Resize Range("A1:C" & lastRow)
.Workbook.Close
End With
End If
Next
Next
Related
Beginner here and I managed to modify a code to extract data from a sheet and copy and paste them to other sheets. Problem is when I click run Macro or the button assigned to the Macro, it is duplicating rows again. Please help me to avoid the duplication.
TIA
Sub UpdateHistory()
Dim wsData As Worksheet, wsCostCode As Worksheet
Dim LastRow As Long, NextRow As Long, i As Long
Dim CostCode As String
Dim Company As String
Dim Invoice As String
Dim Price As Double
Application.ScreenUpdating = False
Set wsData = Sheets("Signed Invoices")
LastRow = wsData.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
CostCode = wsData.Range("A" & i).Value
Company = wsData.Range("B" & i).Value
Invoice = wsData.Range("C" & i).Value
Total = wsData.Range("D" & i).Value
If WorksheetExists(CostCode) = True Then
Set wsCostCode = Sheets(CostCode)
NextRow = wsCostCode.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsCostCode.Range("A" & NextRow).Value = CostCode
wsCostCode.Range("B" & NextRow).Value = Company
wsCostCode.Range("C" & NextRow).Value = Invoice
wsCostCode.Range("D" & NextRow).Value = Total
Else
wsData.Range("A1:D1").Copy
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = CostCode
ActiveSheet.Cells(1, 1).PasteSpecial
ActiveSheet.Range("A2").Value = CostCode
ActiveSheet.Range("B2").Value = Company
ActiveSheet.Range("C2").Value = Invoice
ActiveSheet.Range("D2").Value = Total
End If
Next
Application.CutCopyMode = False
Sheets("Signed Invoices").Select
Application.ScreenUpdating = True
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
When you find that your code isn't doing what you expect, try stepping through it line-by-line and see exactly where and when it goes wrong. You can do this by pressing F8 while your cursor is anywhere in your macro. I also recommend commenting out Application.ScreenUpdating = False until your code is working as expected. Otherwise, following the code's behavior can become difficult when the code is supposed to write things to worksheets.
You've found that your code is duplicating entries. Let's check all places in your macro that write data to the sheet. There is only one place: inside your For i = 2 to LastRow loop. Because you have set up a loop, you are expecting (or at least preparing) for this block of code to run more than once. The next question should be, why is the data not changing between two iterations like you're expecting?
Check that Else block of code. It seems like you copy the headers, add a new sheet, and then use the ActiveSheet to specify which sheet to write the data. Is ActiveSheet the sheet you think it is? (Very easy to verify with line-by-line debugging.) If you really want to use ActiveSheet, make sure the sheet you expect to be active is active with Worksheets(Worksheets.Count).Activate. This will activate the last worksheet, which is where you want to write your data.
Try stepping line-by-line through your code and see if this is correct before modifying your code.
you all were a great help with my last issue, so I figured Id ask another question. I am currently creating a code that keeps track of a mailroom's inventory. The code that I am working on is a textbox that whenever something is typed, it copies the value to the excel and it triggers an advanced search. I want to use xlfiltercopy to prevent visual damage to the excel sheet and so it is easier to update the listbox in the userform with the filtered information. Please let me know if you can find a reason that the error "AdvancedFilter method of Range class failed"
EDIT: If possible, I would like to email the entire excel to someone to see if the program works on another computer. I cannot physically think of a way to get it to work. Please consider it!
' Input on the 2nd page
' This code will update the list box below automatically as you type a name
Private Sub TextBox5_Change()
If Me.TextBox5.Value = "" Then
Exit Sub
End If
Dim wks As Worksheet
Set wks = ThisWorkbook.Sheets("Mail_Inventory")
Dim rgData As Range
Dim rgCriteria As Range
Dim rgOutput As Range
Dim currentinventory As Long
Dim filteredcurrent As Long
Dim temp As Long
temp = wks.Range("AS1").Value
If temp > 0 Then
wks.ListObjects("CurrentFiltered").DataBodyRange.Rows.Delete
End If
wks.Range("AP6").Value = Me.TextBox5.Value
currentinventory = wks.Range("A1").Value
'Set rgData = ThisWorkbook.Worksheets("Mail_Inventory").Range("A2:H" & currentinventory + 2)
'Set rgCriteria = ThisWorkbook.Worksheets("Mail_Inventory").Range("AP5:AP6")
'Set rgOutput = ThisWorkbook.Worksheets("Mail_Inventory").Range("AS2:AZ2")
Set rgData = Range("A2:H" & currentinventory + 2)
Set rgCriteria = Range("AP5:AP6")
Set rgOutput = Range("AS2:AZ2")
rgData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rgCriteria, CopytoRange:=rgOutput
'wks.Range("A2:H" & currentinventory + 2).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wks.Range("AP5:AP6"), CopyToRange:=wks.Range("AS2:AZ2")
'filteredcurrent = wks.Range("AS1").Value
'Me.ListBox2.Clear
'Me.ListBox2.RowSource = wks.Range("AS2:AV" & filteredcurrent + 2)
I have a list of files with the same structure and I want to extract some information from columns A, B, and C and print it to another workbook.
I found a way to do it for a single file, but now I don't understand how can I do it using the list of given files. I tried using collections, but it doesn't work.
Here's what I came up with:
Sub Pulsante1_Click()
Dim FileGeStar As Variant
Dim myCol As Collection
Set myCol = New Collection
myCol.Add "C:\Users\xxx\Desktop\articoli_def.xlsx"
myCol.Add "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx"
For Each FileGeStar In myCol
Workbooks.Open Filename:=FileGeStar
FileGeStar = Application.ActiveWorkbook.Name
Dim Code As String
Dim Description As String
Dim FilePath As String
Dim i As Long
i = 2
While Range("A" & i) <> ""
FilePath = Application.ActiveWorkbook.Path
Code = Trim(Range("A" & i).Value)
Description = Trim(Range("B" & i).Value)
Workbooks("Report.xlsm").Worksheets(1).Range("A" & i).Value = FilePath
Workbooks("Report.xlsm").Worksheets(1).Range("B" & i).Value = Code
Workbooks("Report.xlsm").Worksheets(1).Range("C" & i).Value = Description
i = i + 1
Wend
Next FileGeStar
End Sub
What can I do?
This might look like an overkill, but I hope the code and comment's are self explanatory:
Option Explicit
Sub Pulsante1_Click()
Dim DestinationWorkbook As Workbook
Set DestinationWorkbook = ThisWorkbook 'I think report.xlsm is the workbook running the code
'if report.xlsm is not the workbook running the code then change thisworkbook for workbooks("Report.xlsm")
'add as many paths as you need to, another way would be to write them in a sheet and loop through to fill the array
Dim MyPaths As Variant
MyPaths = Array("C:\Users\xxx\Desktop\articoli_def.xlsx", "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx")
'Declare a workbook variable for the source workbooks
Dim SourceWorkbook As Workbook
'Declare a long variable to loop through your path's array
Dim i As Long
'loop through the start to the end of your array (will increase as the array does)
For i = LBound(MyPaths) To UBound(MyPaths)
Set SourceWorkbook = OpenWorkbook(MyPaths(i)) 'this will set the workbook variable and open it
CopyData SourceWorkbook, DestinationWorkbook 'this will copy the data to your destination workbook
SourceWorkbook.Close , False
Set SourceWorkbook = Nothing
Next i
End Sub
Private Function OpenWorkbook(FullPath As String) As Workbook
Set OpenWorkbook = Workbooks.Open(FullPath, False, True)
End Function
Private Sub CopyData(wbO As Workbook, wbD As Workbook)
'this procedure calculates the last row of your source workbook and loops through all it's data
'later calls the AddDataToMasterWorkbook procedure to paste the data
With wbO.Sheets(1) 'Im assuming your source workbook has the data on sheet1
Dim LastRow As Long
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Dim FilePath As String
FilePath = wbO.Path
Dim Code As String
Dim Description As String
Dim C As Range
For Each C In .Range("A2:A" & LastRow) 'this will loop from A2 to the last row with data
Code = Trim(C)
Description = Trim(C.Offset(, 1))
AddDataToMasterWorkbook wbD, FilePath, Code, Description
Next C
End With
End Sub
Private Sub AddDataToMasterWorkbook(wb As Workbook, FilePath As String, Code As String, Description As String)
'This procedure calculates the last row without data and adds the items you need every time
With wb.Sheets(1)
Dim LastRow As Long
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & LastRow) = FilePath
.Range("B" & LastRow) = Code
.Range("C" & LastRow) = Description
End With
End Sub
To loop though files, you can indeed use a collection, or an array, you can also loop through all files in directory with certain extension, or partial file name. Check out DIR function.
Best not to use ActiveWorkbook, better approach would be to set a workbook object like so: Set wb = Workbooks.Open(fullPathToYourWorkbook).
For what you're doing, there's no need to go row by row, much more efficient way would be to copy entire range, not only it's a lot quicker but also it's only 1 line of code; assuming your destination is ThisWorkbook.Sheets(1) and wb object is set: wb.Range("A:C").Copy Destination:=Thisworkbook.Sheets(1).Range("A:C"). If you need to edit copied data (trim or whatever) consider Range Replace method.
However, if you want to go row by row for whatever reason, as BigBen mentioned in the comment - get rid of While loop.
It's a good idea to set Application.ScreenUpdating to False when opening/closing workbooks, then back to True once it's all done. It will prevent user from accidentaly clicking something etc and will make it look like it's not opening any workbook.
Here's my approach (untested) assuming the workbook you want to copy data to is Workbooks("Report.xlsm").Worksheets(1):
Sub Pulsante1_Click()
'set workbook object for the destination workbook
set wb_dest = Workbooks("Report.xlsm").Worksheets(1)
'disable screen updating
Application.ScreenUpdating = False
For Each target_wb In Array("C:\Users\xxx\Desktop\articoli_def.xlsx", "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx")
'set wb object and open workbook
Set wb = Workbooks.Open(target_wb)
'find last row in this workbooks in columns A:B (whichever is greater)
LastRow = wb.Range("A:B").Find(What:="*", After:=wb.Range("A1"), SearchDirection:=xlPrevious).row
'copy required data
wb.Range("A1:B" & LastRow).Copy Destination:=wb_dest.Range("B1:C" & LastRow)
'fill column A with path to the file
wb_dest.Range("A1:A" & LastRow).Value = wb.Path
'close workbook
wb.Close False
Next
'enable screen updating
Application.ScreenUpdating = True
End Sub
Obviously an array is not the best approach if you have loads of different files, collection would be a lot clearer to read and edit in the future, unless you want to create a dynamic array, but there's no need for that in my opinion. I didn't declare variables or write any error handling, it's a simple code just to point you in the right direction.
If you want to disable workbook events or/and alerts, you can set Application.DisplayAlerts and Application.EnableEvents to False temporarily.
I'm trying to do the following using vba:
I automatically gather data in Excel and want to paste it in an existing PowerPoint-Chart.
It is working fine, that's the way i do it (the paste-to-powerpoint-part):
Dim myChart As PowerPoint.Chart
Dim myChart As PowerPoint.Chart
Dim myData As PowerPoint.ChartData
Dim myWkb As Excel.Workbook
Dim myWks As Excel.Worksheet
Dim wbcd As Workbook
For chnmb = 1 To 1000
On Error Resume Next
Set myChart = ppSlide.Shapes(chnmb).Chart
'test_name = myChart.Name
If myChart.Name = "" Then Else Exit For
Next
I am doing this above (surely not the perfect way) because I don't know the Chart-Name (it is supposed to work for different Charts in different ppt-Files). After that:
Set myData = myChart.ChartData
Set myWkb = myData.Workbook
Set myWks = myWkb.Worksheets(1)
dat_area = "A1:" & Cells(1 + rowct, 1 + colct).Address(RowAbsolute:=False, ColumnAbsolute:=False)
myWks.ListObjects(1).Resize myWks.Range(dat_area)
That is the part not working.
I manage to fill data into the Chart using:
myWks.Cells(j, i).Value = Workbooks("ppt-tool.xlsm").Sheets("Acc_Data").Cells(Row + j, 1 + i).Value
(via for-next; I don't want to paste the data but fill in every field) and to later edit the Chart, but it won´t change the data-area (with the blue border around it) of the ppt-Chart.
Strangely, if I create a new Chart using
Set myChart = ppSlide.Shapes.AddChart2(297, xlBarStacked100).Chart
I manage to resize the data area (with the same resize-code), but it's not working with existing Charts. Incidentally, I don't want to link the ppt-Chart to Excel (because the Excel-Tool is used over and over again with no data saved and the ppt-Charts may have to be edited later again).
I'm trying to find the rows with data in my source data sheet and then copy some of the columns into various places in my destination worksheet using VBA. I have successfully done this for a list with 12k lines but when I do some test data, it only copies the first 12 rows out of 19 rows of data....
Sub Header_Raw()
Dim dataBook As Workbook
Dim Header_Raw As Worksheet, Header As Worksheet
Dim dataSource As Range, dataDest As Range
Dim sourceDataRowCount As Integer, index As Integer
Set dataBook = Application.ThisWorkbook
Set sheetSource = dataBook.Sheets("Header_Raw")
Set sheetDest = dataBook.Sheets("Header")
Set dataSource = sheetSource.Range("B4", _
sheetSource.Range("J90000").End(xlUp))
sourceDataRowCount = dataSource.Rows.Count
Set dataDest = sheetDest.Range("B13", "B" & _
sourceDataRowCount)
For index = 1 To sourceDataRowCount
dataDest(index, 1).Value = dataSource(index, 1).Value
dataDest(index, 2).Value = dataSource(index, 2).Value
Next index
End Sub
If you can help tell me what I have done wrong, that would be great
thanks
Julie
Make your life a bit easier with simple debugging. Run the following:
Sub HeaderRaw()
'Dim all the variables here
Set dataBook = Application.ThisWorkbook
Set SheetSource = dataBook.Sheets("Header_Raw")
Set sheetDest = dataBook.Sheets("Header")
Set dataSource = SheetSource.Range("B4", SheetSource.Range("J90000").End(xlUp))
SheetSource.Activate
dataSource.Select
End Sub
Now you will see what is your dataSource, as far as it is selected. Probably it is not what you expect.