Dear all big brothers and sister,
Is it possible to modified the following macro if the table label is merged? (I posted the file as an example).
Option Explicit
Sub test()
Dim PCT As Workbook, main As Workbook, z(1 To 1, 1 To 5), i As Long, pctn, idate, pt As PivotTable, c, firstaddress As String, irow As Long
On Error Resume Next: Set PCT = Workbooks("PCT-after.xls")
If Err.Number <> 0 Then
MsgBox "Please open PCT.xls file and try again", vbCritical: Exit Sub
End If: Set main = ActiveWorkbook: Set pt = main.ActiveSheet.PivotTables(1)
If Err.Number <> 0 Then
MsgBox "Pivot table for processing is not found on activesheet of this workbook", vbCritical: Exit Sub
End If
irow = Application.InputBox("Please enter row number for PCT.xls to input data (same row is used for all students)", Type:=1): If irow = 0 Then Exit Sub
Application.ScreenUpdating = False: With PCT.Sheets("Name List"): pctn = .Range(.[a5], .Cells(Rows.Count, "a").End(xlUp)): End With: With main.Sheets(1)
idate = .[d1:d100].Find("Report Date:", , xlValues, xlWhole).Offset(, 1): With pt
For i = 1 To UBound(pctn)
Set c = .TableRange1.Find(pctn(i, 1), , xlValues, xlPart)
If Not c Is Nothing Then
firstaddress = c.Address
Do
If c.PivotCell.PivotCellType = xlPivotCellSubtotal Then
z(1, 1) = c.Offset(, 3): z(1, 2) = c.Offset(, 5)
z(1, 3) = .GetData("' % primary sales of closed leads' 'Campaign Name' 'maturing mortgage' 'RM Name'" & Trim(pctn(i, 1)) & " 99999*")
z(1, 4) = .GetData("' % Primary sales of closed leads' 'Campaign Name' 'maturing term deposit' 'RM Name'" & Trim(pctn(i, 1)) & " 99999*")
z(1, 5) = .GetData("' % Primary sales of closed leads' 'Campaign Name' 'signficiant deposit' 'RM Name'" & Trim(pctn(i, 1)) & " 99999*")
With PCT.Sheets(Trim(pctn(i, 1)))
With .Cells(irow, 1): .Value = "'" & idate: With .Offset(, 26).Resize(, 5): .Value = z: .NumberFormat = "0.00%"
End With: End With: End With: End If: Set c = .TableRange1.FindNext(c): Loop Until c Is Nothing Or c.Address = firstaddress
End If: Next: End With: End With: Application.ScreenUpdating = True: End Sub
Bookmarks