在数据透视表旁复制链接

vivid_ck

较之前帖稍微简化了下代码
想把sheet1（明细）中的F列链接复制到sheet2（汇总）“数据透视表”对应行的右侧，可试了几次，以下这段代码在模块里单独运行OK，但放到了thisworkbook的open里，就是运行不起来，不知能否解决，请赐教，谢谢

1. '数据透视表上做链接**************************************************************************
   
2. Sheet2.Range("C3").Value = "链接"
   
3. For j = 1 To Sheet2.[A65536].End(3).Row
   
4. Set fcell = Sheet1.Range("e:e").Find(Sheet2.Cells(j, 1))
   
5. If Not fcell Is Nothing Then
   
6. Sheet1.Range("f" & fcell.Row).Copy Sheet2.Cells(j, 3)
   
7. Else
   
8. Sheet2.Cells(j, 3) = ""
   
9. End If
   
10. Set rng = Nothing
    
11. Next

复制代码

以下是所有代码

1. Private Sub Workbook_Open()
   
2. Application.ScreenUpdating = False
   
3. Application.DisplayAlerts = False
   
4. On Error Resume Next
   
5. Dim j%, fcell As Range
   
6.     '定义名称************************************************************************************
   
7.         ActiveWorkbook.Names("数据").RefersToR1C1 = _
   
8.         "=OFFSET(明细!R1C1,,,COUNTA(明细!C1),COUNTA(明细!R1))"
   
9.     '数透表************************************************************************
   
10.     Sheets.Add
    
11.     ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="数据" _
    
12.         , Version:=6).CreatePivotTable TableDestination:="Sheet1!R3C1", TableName _
    
13.         :="数据透视表1", DefaultVersion:=6
    
14.     Sheets("Sheet1").Select
    
15.     Cells(3, 1).Select
    
16.     With ActiveSheet.PivotTables("数据透视表1")
    
17.         .ColumnGrand = True
    
18.         .HasAutoFormat = True
    
19.         .DisplayErrorString = False
    
20.         .DisplayNullString = True
    
21.         .EnableDrilldown = True
    
22.         .ErrorString = ""
    
23.         .MergeLabels = False
    
24.         .NullString = ""
    
25.         .PageFieldOrder = 2
    
26.         .PageFieldWrapCount = 0
    
27.         .PreserveFormatting = True
    
28.         .RowGrand = True
    
29.         .SaveData = True
    
30.         .PrintTitles = False
    
31.         .RepeatItemsOnEachPrintedPage = True
    
32.         .TotalsAnnotation = False
    
33.         .CompactRowIndent = 1
    
34.         .InGridDropZones = False
    
35.         .DisplayFieldCaptions = True
    
36.         .DisplayMemberPropertyTooltips = False
    
37.         .DisplayContextTooltips = True
    
38.         .ShowDrillIndicators = True
    
39.         .PrintDrillIndicators = False
    
40.         .AllowMultipleFilters = False
    
41.         .SortUsingCustomLists = True
    
42.         .FieldListSortAscending = False
    
43.         .ShowValuesRow = False
    
44.         .CalculatedMembersInFilters = False
    
45.         .RowAxisLayout xlCompactRow
    
46.     End With
    
47.     With ActiveSheet.PivotTables("数据透视表1").PivotCache
    
48.         .RefreshOnFileOpen = False
    
49.         .MissingItemsLimit = xlMissingItemsDefault
    
50.     End With
    
51.     ActiveSheet.PivotTables("数据透视表1").RepeatAllLabels xlRepeatLabels
    
52.     ActiveWorkbook.ShowPivotTableFieldList = True
    
53.     With ActiveSheet.PivotTables("数据透视表1").PivotFields("学期")
    
54.         .Orientation = xlRowField
    
55.         .Position = 1
    
56.     End With
    
57.     With ActiveSheet.PivotTables("数据透视表1").PivotFields("年级")
    
58.         .Orientation = xlRowField
    
59.         .Position = 2
    
60.     End With
    
61.     With ActiveSheet.PivotTables("数据透视表1").PivotFields("课程")
    
62.         .Orientation = xlRowField
    
63.         .Position = 3
    
64.     End With
    
65.     With ActiveSheet.PivotTables("数据透视表1").PivotFields("单元")
    
66.         .Orientation = xlRowField
    
67.         .Position = 4
    
68.     End With
    
69.     ActiveSheet.PivotTables("数据透视表1").AddDataField ActiveSheet.PivotTables("数据透视表1" _
    
70.         ).PivotFields("课名"), "计数项:课名", xlCount
    
71.     With ActiveSheet.PivotTables("数据透视表1").PivotFields("课名")
    
72.         .Orientation = xlRowField
    
73.         .Position = 5
    
74.     End With
    
75.     Range("B4").Select
    
76.     ActiveWindow.FreezePanes = True
    
77.     ActiveWorkbook.ShowPivotTableFieldList = False
    
78.     Sheets("Sheet1").Select
    
79.     Sheets("Sheet1").Name = "汇总"
    
80.     '数据透视表上做链接**************************************************************************
    
81.     Sheet2.Range("C3").Value = "链接"
    
82.     For j = 1 To Sheet2.[A65536].End(3).Row
    
83.         Set fcell = Sheet1.Range("e:e").Find(Sheet2.Cells(j, 1))
    
84.         If Not fcell Is Nothing Then
    
85.                   Sheet1.Range("f" & fcell.Row).Copy Sheet2.Cells(j, 3)
    
86.             Else
    
87.                   Sheet2.Cells(j, 3) = ""
    
88.         End If
    
89.         Set rng = Nothing
    
90.     Next
    
91.         '************************************************************************************
    
92.     Application.DisplayAlerts = True
    
93.     Application.ScreenUpdating = True
    
94. End Sub
    
95. 
    
96. 
    
97. Private Sub Workbook_BeforeClose(Cancel As Boolean)
    
98.     Application.ScreenUpdating = False
    
99.     Application.DisplayAlerts = False
    
100.     On Error Resume Next
     
101.     Sheets("汇总").Select
     
102.     ActiveWindow.SelectedSheets.Delete
     
103.     Application.DisplayAlerts = True
     
104.     Application.ScreenUpdating = True
     
105.     ActiveWorkbook.Save
     
106. End Sub
     
107. 
     

复制代码