[已解决]如何汇总已命名的区域

cionysus

文件夹内有多个excel文件，每个excel文件中的sheet分两种：一种是其中含有一个已经命名的矩形区域（在例子中，每个区域的都命名为print_area）；另一种是空的sheet或者不含任何命名区域的sheet。


现在想把这个文件夹内，所有excel文件中所有的命名区域，都汇总到一个新文件result.xls中，原excel文件中的每个命名区域都在result中单独占一个sheet。

原excel文件中每个命名区域中含有公式和引用，这里希望提取到result中的是不含公式和引用的最终的结果。

result中sheet的名字为每个命名区域原所在excel文件名加原sheet名。

result里每张sheet内的内容都紧靠左上角。

期望的结果见result.xls。

汇总已命名的区域.rar (9.7 KB, 下载次数: 3)

2013-9-6 12:17 上传

点击文件名下载附件
汇总已命名的区域

最佳答案

月排行榜 / 总排行榜

wp8680

2013-9-6 14:08

汇总已命名的区域.rar (25.74 KB, 下载次数: 2)

2013-9-6 14:07 上传

点击文件名下载附件

1. Sub 提取名称区域()
   
2.     Dim ph$, wb As Workbook, sh As Worksheet, arr()
   
3.     Dim mypath$, k%, m%, thissh As Worksheet
   
4.     On Error Resume Next
   
5.     mypath = ThisWorkbook.Path & ""
   
6.     ph = Dir(mypath & "*.xls*")
   
7.     Do
   
8.         Set wb = GetObject(mypath & ph)
   
9.         k = 1
   
10.         For Each sh In wb.Sheets
    
11.             ReDim Preserve arr(1 To 2, 1 To k)
    
12.             arr(1, k) = sh.Range("Print_Area")
    
13.             arr(2, k) = sh.Name
    
14.             If Err.Number = 0 Then k = k + 1 Else Err.Clear
    
15.         Next sh
    
16.         wb.Close
    
17.         For m = 1 To UBound(arr)
    
18.             Set thissh = ThisWorkbook.Sheets(Left(ph, Len(ph) - 4) & "-" & arr(2, m))
    
19.             If Err.Number <> 0 Then
    
20.                 ThisWorkbook.Sheets.Add after:=Sheets(Worksheets.Count)
    
21.                 ActiveSheet.Name = Left(ph, Len(ph) - 4) & "-" & arr(2, m)
    
22.                 Err.Clear
    
23.                 Set thissh = ThisWorkbook.Sheets(Left(ph, Len(ph) - 4) & "-" & arr(2, m))
    
24.             End If
    
25.             thissh.Range("a1").Resize(UBound(arr(1, m), 1), UBound(arr(1, m), 2)) = arr(1, m)
    
26.         Next m
    
27.         ph = Dir
    
28.     Loop While ph <> "" And ph <> ThisWorkbook.Name
    
29. End Sub

复制代码

跳转到最佳答案楼层

wp8680

汇总已命名的区域.rar (25.74 KB, 下载次数: 2)

2013-9-6 14:07 上传

点击文件名下载附件

1. Sub 提取名称区域()
   
2.     Dim ph$, wb As Workbook, sh As Worksheet, arr()
   
3.     Dim mypath$, k%, m%, thissh As Worksheet
   
4.     On Error Resume Next
   
5.     mypath = ThisWorkbook.Path & ""
   
6.     ph = Dir(mypath & "*.xls*")
   
7.     Do
   
8.         Set wb = GetObject(mypath & ph)
   
9.         k = 1
   
10.         For Each sh In wb.Sheets
    
11.             ReDim Preserve arr(1 To 2, 1 To k)
    
12.             arr(1, k) = sh.Range("Print_Area")
    
13.             arr(2, k) = sh.Name
    
14.             If Err.Number = 0 Then k = k + 1 Else Err.Clear
    
15.         Next sh
    
16.         wb.Close
    
17.         For m = 1 To UBound(arr)
    
18.             Set thissh = ThisWorkbook.Sheets(Left(ph, Len(ph) - 4) & "-" & arr(2, m))
    
19.             If Err.Number <> 0 Then
    
20.                 ThisWorkbook.Sheets.Add after:=Sheets(Worksheets.Count)
    
21.                 ActiveSheet.Name = Left(ph, Len(ph) - 4) & "-" & arr(2, m)
    
22.                 Err.Clear
    
23.                 Set thissh = ThisWorkbook.Sheets(Left(ph, Len(ph) - 4) & "-" & arr(2, m))
    
24.             End If
    
25.             thissh.Range("a1").Resize(UBound(arr(1, m), 1), UBound(arr(1, m), 2)) = arr(1, m)
    
26.         Next m
    
27.         ph = Dir
    
28.     Loop While ph <> "" And ph <> ThisWorkbook.Name
    
29. End Sub

复制代码

cionysus

wp8680 发表于 2013-9-6 14:08

很感谢您的帮助！
我还有一个小问题，就是例子中原来命名的区域都是加边框的，但是汇总的表中，这些区域的边框都没有了，请问如何保留原区域的外边框？

wp8680

cionysus 发表于 2013-9-6 14:44
很感谢您的帮助！
我还有一个小问题，就是例子中原来命名的区域都是加边框的，但是汇总的表中，这些区域 ...

1. Sub 提取名称区域()
   
2.     Dim ph$, wb As Workbook, sh As Worksheet, arr()
   
3.     Dim mypath$, k%, m%, thissh As Worksheet
   
4.     On Error Resume Next
   
5.     mypath = ThisWorkbook.Path & ""
   
6.     ph = Dir(mypath & "*.xls*")
   
7.     Do
   
8.         Set wb = GetObject(mypath & ph)
   
9.         k = 1
   
10.         For Each sh In wb.Sheets
    
11.             ReDim Preserve arr(1 To 2, 1 To k)
    
12.             arr(1, k) = sh.Range("Print_Area")
    
13.             arr(2, k) = sh.Name
    
14.             If Err.Number = 0 Then k = k + 1 Else Err.Clear
    
15.         Next sh
    
16.         wb.Close
    
17.         For m = 1 To UBound(arr)
    
18.             Set thissh = ThisWorkbook.Sheets(Left(ph, Len(ph) - 4) & "-" & arr(2, m))
    
19.             If Err.Number <> 0 Then
    
20.                 ThisWorkbook.Sheets.Add after:=Sheets(Worksheets.Count)
    
21.                 ActiveSheet.Name = Left(ph, Len(ph) - 4) & "-" & arr(2, m)
    
22.                 Err.Clear
    
23.                 Set thissh = ThisWorkbook.Sheets(Left(ph, Len(ph) - 4) & "-" & arr(2, m))
    
24.             End If
    
25.             With thissh.Range("a1").Resize(UBound(arr(1, m), 1), UBound(arr(1, m), 2))
    
26.                 .Value = arr(1, m)
    
27.                 '            .Borders.LineStyle = 1
    
28.                 .Borders(xlEdgeLeft).LineStyle = 1
    
29.                 .Borders(xlEdgeTop).LineStyle = 1
    
30.                 .Borders(xlEdgeBottom).LineStyle = 1
    
31.                 .Borders(xlEdgeRight).LineStyle = 1
    
32.             End With
    
33.         Next m
    
34.         ph = Dir
    
35.     Loop While ph <> "" And ph <> ThisWorkbook.Name
    
36. End Sub
    

复制代码