Without any details, it is impossible to know. There are many reasons this could be happening.
You should probably post the code that is slow, and details about the data it is accessing, and how you are connecting to it.
The first thing you should ask yourself, is what, if anything changed in the past week, and start there.
Here is the VBA Code. I know it is quite big but the same I have used in last month and it doest took a long time compared to this time.
As per my knowledge nothing was change in the past week
Option Explicit
Sub populate_to_ppt()
'Sub create_grid_from_banner_sht()
Dim wb As Workbook
Dim scratch_sht As Worksheet
Dim banner_sht As Worksheet
Dim scratch_ptr As Range
Dim PPT_template_str As String
Dim PPT_app As PowerPoint.Application
Dim PPT_template As PowerPoint.Presentation
Dim active_slide As PowerPoint.Slide
Dim source_start_row As Integer, source_end_row As Integer
Dim tableA_col_name_row As Integer, tableB_col_name_row As Integer, tableC_col_name_row As Integer
Dim t_wb As Workbook, t_ws As Worksheet, measures_sht As Worksheet
Dim stub_rg, col_rg, x, m_drop
Dim t_measure As String
Dim i As Integer, m As Integer
Dim num_banner_points As Integer
Dim t_ptr As Range
Dim b As Range
Dim measure_start_row As Integer, measure_end_row As Integer
Dim tag_arr As Variant
Dim table_type As String
Dim time_test As Long
Dim user_inputs_sht As Worksheet
Dim u_start As Integer, u_end As Integer
'time_test = Now()
Dim header_row As Integer
Dim b_num_cols As Integer
Dim r_sht As Worksheet
Dim r_sht_arr As Variant
Set wb = ActiveWorkbook
Set scratch_sht = wb.Sheets("scratch_sht")
Set scratch_ptr = scratch_sht.Range("B1")
Set measures_sht = wb.Sheets("measures")
Set banner_sht = wb.Sheets("banner_sht")
Set user_inputs_sht = wb.Sheets("user inputs")
Set r_sht = wb.Sheets("replace in headers")
u_start = user_inputs_sht.Range("B2").Value
u_end = user_inputs_sht.Range("B3").Value
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'''start rows
source_start_row = u_start: source_end_row = u_end
tableA_col_name_row = 7: tableB_col_name_row = 8: tableC_col_name_row = 7
'HARD CODED MEASURE START AND END ROW ON MEASURES WORKSHEET
measure_start_row = 2: measure_end_row = 40
'''
'open PPT
PPT_template_str = ThisWorkbook.Path & "\" & Dir(ThisWorkbook.Path & "\*template*")
Set PPT_app = CreateObject("PowerPoint.Application")
Set PPT_template = PPT_app.Presentations.Open(PPT_template_str)
'loop through each banner
'loop through rows in source sheet
For i = source_start_row To source_end_row
table_type = banner_sht.Range("Q" & i).Value
'set header rows based on template
Select Case table_type
Case "B": header_row = tableB_col_name_row
Case "C": header_row = tableC_col_name_row
Case Else: header_row = tableA_col_name_row
End Select
'clear sheet
measures_sht.Range("C:O").Delete
'open the file
Set t_wb = Workbooks.Open(ThisWorkbook.Path & "\" & banner_sht.Range("A" & i) & ".xlsx")
Set t_ws = t_wb.Sheets(banner_sht.Range("B" & i).Value)
t_ws.Activate
t_ws.Cells.MergeCells = False
t_ws.Range("A" & header_row).Value = "banner"
'loop through each measure, pull data
For m = measure_start_row To measure_end_row
t_measure = measures_sht.Range("A" & m).Value
t_ws.Range("A:A").Select
Selection.Find(What:=t_measure, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Select
Set stub_rg = Selection.EntireRow
Set b = banner_sht.Cells(i, 3)
'loop through each banner column
While b.Value <> ""
Set col_rg = t_ws.Range(b.Value & 1).EntireColumn
' Set x = Intersect(stub_rg, col_rg.EntireColumn)
Set x = t_ws.Cells(stub_rg.Row, col_rg.Column)
'template C base exception, shift left 1
If table_type = "C" And t_measure = "n" And x.Value = "" Then Set x = x.Offset(0, -1)
Set m_drop = measures_sht.Cells(m, b.Column)
x.Copy m_drop
Set b = b.Offset(0, 1)
Wend
Next
b_num_cols = Range(banner_sht.Cells(i, 3), banner_sht.Cells(i, 3).End(xlToRight)).Columns.Count
Call format_sht(measures_sht, b_num_cols, table_type)
'0 = ^K^, 1 = string, 2 = range
ReDim tag_arr(0 To 10, 0 To 2)
'headers
tag_arr(0, 0) = "^K1^": tag_arr(0, 1) = "": Set tag_arr(0, 2) = Range(measures_sht.Range("C1").Offset(1, 0), measures_sht.Range("C1").Offset(1, b_num_cols - 1))
'data blocks
tag_arr(2, 0) = "^K3^": tag_arr(2, 1) = "": Set tag_arr(2, 2) = Range(measures_sht.Range("C4"), measures_sht.Range("C9").Offset(0, b_num_cols - 1))
tag_arr(3, 0) = "^K4^": tag_arr(3, 1) = "": Set tag_arr(3, 2) = Range(measures_sht.Range("C11"), measures_sht.Range("C22").Offset(0, b_num_cols - 1))
tag_arr(4, 0) = "^K5^": tag_arr(4, 1) = "": Set tag_arr(4, 2) = Range(measures_sht.Range("C24"), measures_sht.Range("C39").Offset(0, b_num_cols - 1))
'COMMENTED OUT tag_arr(5,0) for ^K6^ AS IT IS FOR CAPABILITIES USAGE
'tag_arr(5, 0) = "^K6^": tag_arr(5, 1) = "": Set tag_arr(5, 2) = Range(measures_sht.Range("C37"), measures_sht.Range("C48").Offset(0, b_num_cols - 1))
'bases - Bases were output in measures worksheet in column C40
tag_arr(6, 0) = "^K7^": tag_arr(6, 1) = "": Set tag_arr(6, 2) = Range(measures_sht.Range("C40"), measures_sht.Range("C40").Offset(0, b_num_cols - 1))
'file and sheet names, good
tag_arr(8, 0) = "^K9^": tag_arr(8, 1) = banner_sht.Cells(i, 2).Value: tag_arr(8, 2) = ""
tag_arr(9, 0) = "^K10^": tag_arr(9, 1) = banner_sht.Cells(i, 1).Value: tag_arr(9, 2) = ""
'low base note, good
tag_arr(10, 0) = "^K11^": tag_arr(10, 1) = measures_sht.Cells(1, 1).Value: tag_arr(10, 2) = ""
'get replacements
r_sht_arr = get_replacements(r_sht)
'close wb
t_wb.Close (False)
'Copy template slides to end of deck
'populate
If table_type = "B" Then
''' IGNORE SLIDE 5 FOR CAPABILITIES USAGE
'''PPT_template.Slides.Range(Array(3, 4, 5)).Copy
PPT_template.Slides.Range(Array(3, 4)).Copy
PPT_template.Slides.Paste PPT_template.Slides.Count + 1
'ADJUSTED SECOND PARAMETER PASSED TO POP_TABLE_SLIDE SUBROUTINE TO ACCOUNT FOR ONLY 2 SLIDES BEING COPIED
Call pop_table_slide(PPT_template, PPT_template.Slides.Count - 1, tag_arr, table_type, b_num_cols, r_sht_arr)
Call pop_table_slide(PPT_template, PPT_template.Slides.Count, tag_arr, table_type, b_num_cols, r_sht_arr)
'CAPABILITIES USAGE SLIDE 5 NOT COPIED
'Call pop_table_slide(PPT_template, PPT_template.Slides.Count, tag_arr, table_type, b_num_cols, r_sht_arr)
ElseIf table_type = "C" Then
''' IGNORE SLIDE 9 FOR CAPABILITIES USAGE
'''PPT_template.Slides.Range(Array(6, 7, 8, 9)).Copy
PPT_template.Slides.Range(Array(6, 7, 8)).Copy
PPT_template.Slides.Paste PPT_template.Slides.Count + 1
'ADJUSTED SECOND PARAMETER PASSED TO POP_TABLE_SLIDE SUBROUTINE TO ACCOUNT FOR ONLY 3 SLIDES BEING COPIED
Call pop_table_slide(PPT_template, PPT_template.Slides.Count - 2, tag_arr, table_type, b_num_cols, r_sht_arr)
Call pop_table_slide(PPT_template, PPT_template.Slides.Count - 1, tag_arr, table_type, b_num_cols, r_sht_arr)
Call pop_table_slide(PPT_template, PPT_template.Slides.Count, tag_arr, table_type, b_num_cols, r_sht_arr)
''''CAPABILITIES USAGE SLIDE 9 COPIED
'''Call pop_table_slide(PPT_template, PPT_template.Slides.Count, tag_arr, table_type, b_num_cols, r_sht_arr)
Else
''' IGNORE SLIDE 2 FOR CAPABILITIES USAGE
'''PPT_template.Slides.Range(Array(1, 2)).Copy
PPT_template.Slides.Range(Array(1)).Copy
PPT_template.Slides.Paste PPT_template.Slides.Count + 1
'ADJUSTED SECOND PARAMETER PASSED TO POP_TABLE_SLIDE SUBROUTINE TO ACCOUNT FOR ONLY 1 SLIDE BEING COPIED
Call pop_table_slide(PPT_template, PPT_template.Slides.Count, tag_arr, table_type, b_num_cols, r_sht_arr)
''''CAPABILITIES USAGE SLIDE 2 COPIED
''''Call pop_table_slide(PPT_template, PPT_template.Slides.Count, tag_arr, table_type, b_num_cols, r_sht_arr)
End If
Erase tag_arr
Next
'delete template slides
Dim z As Integer
For z = 1 To 9
PPT_template.Slides.Range(Array(1)).Delete
Next
'save the output
Dim nm As String
nm = Left(PPT_template.Name, Len(PPT_template.Name) - 4)
PPT_template.SaveAs PPT_template.Path & "\" & nm & "_output.pptx"
'
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub format_sht(measures_sht, b_num_cols, table_type)
Dim rg As Range
Dim cell As Range
Dim header_rg As Range
'HARD CODED END OF MEASURE RANGE, IGNORING THE n OR Sample Size (c/s) ROW
Set rg = Range(measures_sht.Range("C4"), measures_sht.Range("C39").Offset(0, b_num_cols - 1))
For Each cell In rg
'Added logic to ignore some text headers that were read in from the input workbooks
If IsNumeric(cell.Value) Then
'remove percents, num format
cell.Value = cell.Value * 100
If cell.Interior.Color <> RGB(255, 255, 255) Then
cell.Value = Application.WorksheetFunction.Round(cell.Value, 1)
cell.NumberFormat = "0.0;-0.0;0.0"
Else
cell.Value = Application.WorksheetFunction.Round(cell.Value, 0)
cell.NumberFormat = "0;-0;0"
End If
''colors
If cell.Interior.Color = RGB(150, 193, 29) Then cell.Interior.Color = RGB(0, 161, 58)
'white font for 80%
If cell.Interior.Color = RGB(255, 150, 0) Then cell.Font.Color = RGB(0, 0, 0)
If cell.Interior.Color = RGB(255, 150, 0) Then cell.Interior.Color = RGB(115, 255, 166)
If cell.Interior.Color = RGB(204, 51, 51) Then cell.Interior.Color = RGB(175, 2, 43)
''
End If
Next cell
'''bases - UPDATED THE HARD CODED BASE ROW FROM 49 TO 40
Set rg = Range(measures_sht.Range("C40"), measures_sht.Range("C40").Offset(0, b_num_cols - 1))
measures_sht.Range("A1") = " "
For Each cell In rg
cell.Font.Color = RGB(113, 113, 113)
cell.Interior.Color = RGB(255, 255, 255)
If cell.Value < 50 Then
cell.Value = cell.Value & "^"
measures_sht.Range("A1").Value = "^Low sample size"
End If
Next cell
'A headers
Set rg = Range(measures_sht.Range("C2"), measures_sht.Range("C2").Offset(0, b_num_cols - 1))
For Each cell In rg
If cell.Value = "" Then
Range(cell, cell.Offset(0, -1)).Merge
End If
Next cell
End Sub
Sub pop_table_slide(PPT_template As Presentation, sl As Integer, ByRef p_tag_arr As Variant, table_type As String, b_num_cols As Integer, r_sht_arr As Variant)
Dim active_slide As PowerPoint.Slide
Dim d As Integer
Dim shp As PowerPoint.Shape
Dim tbl As PowerPoint.Table
Dim r As Integer, c As Integer, p As Integer
Dim k3r As Integer, k3c As Integer
'Call print_arr(r_sht_arr)
'Exit Sub
Set active_slide = PPT_template.Slides(sl)
'populate table
For Each shp In active_slide.Shapes
If shp.HasTable Then
Set tbl = shp.Table
'resize table
For d = b_num_cols + 2 To tbl.Columns.Count
tbl.Columns(b_num_cols + 2).Delete
Next
For r = 1 To tbl.Rows.Count
For c = 1 To tbl.Columns.Count
'does it even have a tag?
If InStr(tbl.cell(r, c).Shape.TextFrame2.TextRange.Text, "^") Then
'check for all tags
For p = LBound(p_tag_arr, 1) To UBound(p_tag_arr, 1)
If InStr(tbl.cell(r, c).Shape.TextFrame2.TextRange.Text, p_tag_arr(p, 0)) Then
'update ranges with tag values
If VarType(p_tag_arr(p, 2)) = 8204 Then
For k3r = 1 To p_tag_arr(p, 2).Rows.Count
For k3c = 1 To p_tag_arr(p, 2).Columns.Count
With tbl.cell(r + k3r - 1, c + k3c - 1).Shape
.TextFrame2.TextRange.Text = p_tag_arr(p, 2).Cells(k3r, k3c).Text
'color if not header rows
If r <> 2 Then
.Fill.ForeColor.RGB = p_tag_arr(p, 2).Cells(k3r, k3c).Interior.Color
.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = p_tag_arr(p, 2).Cells(k3r, k3c).Font.Color
End If
End With
Next
Next
'update single cell text with tag value
ElseIf p_tag_arr(p, 1) <> "" Then
tbl.cell(r, c).Shape.TextFrame2.TextRange.Text = Replace(tbl.cell(r, c).Shape.TextFrame2.TextRange.Text, p_tag_arr(p, 0), p_tag_arr(p, 1))
End If
End If
Next
End If
'if row = 2 and template is not B, merge the headers
If (r = 2) And (c Mod 2 = 0) And table_type <> "B" Then
tbl.cell(r, c).Merge tbl.cell(r, c + 1)
End If
'if row = last and template is not B, merge the bases
If (r = tbl.Rows.Count) And (c Mod 2 = 0) And table_type <> "B" Then
tbl.cell(r, c).Shape.TextFrame2.TextRange.Text = _
tbl.cell(r, c).Shape.TextFrame2.TextRange.Text & " / " & tbl.cell(r, c + 1).Shape.TextFrame2.TextRange.Text
tbl.cell(r, c + 1).Shape.TextFrame2.TextRange.Text = ""
tbl.cell(r, c).Merge tbl.cell(r, c + 1)
End If
Next
Next
'replacements
Call make_replacements(tbl, r_sht_arr)
End If
'low base note - ^K11^
If shp.HasTextFrame Then
If shp.TextFrame2.TextRange.Text = "^K11^" Then shp.TextFrame2.TextRange.Text = p_tag_arr(10, 1)
End If
Next shp
End Sub
Sub update_file_tab_in_banner_sht()
Dim wb As Workbook
Dim banner_sht As Worksheet
Dim i As Integer, m As Integer
Dim StrFile As String
Dim data_wb As Workbook
Dim sh As Worksheet
Set wb = ActiveWorkbook
Set banner_sht = wb.Sheets("banner_sht")
i = 2
StrFile = ThisWorkbook.Path & "\" & Dir(ThisWorkbook.Path & "\*.xlsx")
'Do While Len(StrFile) > 0
Do While StrFile <> ThisWorkbook.Path & "\"
Set data_wb = Workbooks.Open(StrFile)
For Each sh In data_wb.Sheets
banner_sht.Range("A" & i).Value = Replace(data_wb.Name, ".xlsx", "")
banner_sht.Range("B" & i).Value = sh.Name
i = i + 1
Next sh
data_wb.Close (False)
StrFile = ThisWorkbook.Path & "\" & Dir
Loop
End Sub
Sub make_replacements(tbl As Table, r As Variant)
Dim c As Integer
Dim i As Integer, j As Integer
Dim txt As String
For c = 2 To tbl.Columns.Count
Debug.Print txt
For i = LBound(r, 1) To UBound(r, 1)
tbl.cell(2, c).Shape.TextFrame2.TextRange.Text = _
Replace(tbl.cell(2, c).Shape.TextFrame2.TextRange.Text, r(i, 1), r(i, 2))
Next
Next
End Sub
Function get_replacements(rsht As Worksheet) As Variant
Dim r As Variant
Dim f_rg As Range
Dim l_rg As Range
Dim i As Integer, j As Integer
Set f_rg = rsht.Range("A2")
Set l_rg = rsht.Range("A1048576").End(xlUp)
r = Range(f_rg, l_rg.Offset(0, 1))
get_replacements = r
End Function
Sub print_arr(r As Variant)
Dim i As Integer, j As Integer
For i = LBound(r, 1) To UBound(r, 1)
For j = LBound(r, 2) To UBound(r, 2)
Debug.Print "r(" & i & ", " & j & ")" & r(i, j)
Next
Next
End Sub
