[µo°Ý] ¦p¦óÅý¦¹µ{¦¡®Ä²v´£°ª?

av8d

1. Private Sub cmdMerge_Click()
   
2. Application.ScreenUpdating = False '«Ì½ª«Ì¹õ¨ê·s
   
3. 
   
4.     Dim a, b, c As Integer '«Å§ia,b,c¬°¾ã¼Æ
   
5.    
   
6.     Dim objsheet As Worksheet
   
7.    
   
8.     WorkName = Excel.ActiveWorkbook.Name '¦¹ÀɮצWºÙ
   
9.    
   
10.     desc = Excel.Workbooks.Add.Name '·sÀÉ®×µøµ¡½s¸¹
    
11.    
    
12.    
    
13.     Application.DisplayAlerts = False  '±Nĵ§i°T®§Ãö³¬
    
14.    
    
15.    
    
16.         
    
17.     i = 6
    
18. 
    
19.     z = 1
    
20.    
    
21.     While Windows(WorkName).ActiveSheet.Range("b" & i) <> ""
    
22.    
    
23.         
    
24.         Filename = Windows(WorkName).ActiveSheet.Range("b" & i) & "." & Windows(WorkName).ActiveSheet.Range("b3")
    
25.         
    
26.         Workbooks.Open Filename:=Excel.Workbooks(WorkName).Path & "\" & Filename
    
27.         
    
28.         
    
29.         sheetname = Windows(WorkName).ActiveSheet.Range("b4")
    
30.         
    
31.         If sheetname <> "" Then
    
32.             
    
33.             'Àˬd¬¡­¶¬O§_¦s¦b
    
34.             flag = 0
    
35.             For j = 1 To Windows(Filename).Parent.Sheets.Count
    
36.                 If Windows(Filename).Parent.Sheets(j).Name = sheetname Then
    
37.                    flag = 1
    
38.                    Exit For
    
39.                 End If
    
40.             Next
    
41.             
    
42.             If flag = 1 Then
    
43.                 Windows(Filename).Parent.Sheets(sheetname).Select  '¤Á´«¬¡­¶
    
44.             End If
    
45.                
    
46.         End If
    
47.         Set objsheet = Windows(Filename).ActiveSheet '¤Á´«µøµ¡
    
48. 
    
49.         'Ū¨ú¨Ó·½ÀɮתºX(¦C¼Æ),Y(¦æ¼Æ)
    
50.         x = Windows(WorkName).ActiveSheet.Range("b1")
    
51.         y = Windows(WorkName).ActiveSheet.Range("b2")
    
52.         
    
53.         
    
54.         a = x '¶}©l¦C
    
55.         b = y '¶}©lÄæ
    
56.       
    
57.         Do While True
    
58.             kk = ""
    
59.             For l = 1 To 10
    
60.                 For k = 1 To 30
    
61.                     If IsError(objsheet.Cells(x + l, k)) = False Then
    
62.                         kk = kk & objsheet.Cells(x + l, k)
    
63.                     End If
    
64.                 Next
    
65.             Next
    
66.             If kk = "" Then Exit Do
    
67.             x = x + 1
    
68.         Loop
    
69.         
    
70.         Do While True
    
71.             kk = ""
    
72.             For l = 1 To 10
    
73.                 For k = 1 To 30
    
74.                     If IsError(objsheet.Cells(k, y + l)) = False Then
    
75.                         kk = kk & objsheet.Cells(k, y + l)
    
76.                     End If
    
77.                 Next
    
78.             Next l
    
79.             If kk = "" Then Exit Do
    
80.             y = y + 1
    
81.         Loop
    
82.         
    
83.         '¿ï¨ú¨Ó·½½d³ò
    
84.          objsheet.Range(objsheet.Cells(a, b), objsheet.Cells(x, y)).Select
    
85.          
    
86.          'copy
    
87.          Selection.Copy
    
88. 
    
89.         '¿ï¨ú¥Øªº
    
90.         Windows(desc).Activate
    
91. 
    
92.         
    
93.         
    
94.         '¦pªG¶K¤W¥H«á·|¤j©ó1048576«h·s¼W¤@­Ó¬¡­¶
    
95.         If (z + x - a + 1) > 65535 Then
    
96.             z = 1
    
97.             Windows(desc).Parent.Sheets.Add
    
98.             Windows(desc).Parent.Sheets(1).Cells(z, 1).Select
    
99.         Else
    
100.             If UCase(Sheet1.Range("b5").Value) = "Y" Then
     
101.                 Windows(desc).ActiveSheet.Cells(z, 1).Value = Windows(WorkName).ActiveSheet.Range("b" & i)
     
102.                 Windows(desc).ActiveSheet.Cells(z, 2).Select
     
103.             Else
     
104.                 Windows(desc).ActiveSheet.Cells(z, 1).Select
     
105.             End If
     
106.         End If
     
107.         
     
108.         ActiveSheet.Paste
     
109.                
     
110.         '¶K¤WÄæ¼e
     
111.         Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
     
112.         SkipBlanks:=False, Transpose:=False
     
113.                         
     
114.         z = z + x - a + 1
     
115.       
     
116.        '±N¨Ó·½ÀÉ®×Ãö³¬
     
117.        Windows(Filename).Close
     
118.         
     
119.         i = i + 1 'Ū¨ú¤U¤@­ÓÀɮצWºÙ
     
120.     Wend
     
121.    
     
122.     Windows(desc).ActiveSheet.Cells(1, 1).Select
     
123.    
     
124.     'ª©­±³]©w¤W¤U¥ª¥k0.5
     
125.         With ActiveSheet.PageSetup
     
126.         .PrintTitleRows = ""
     
127.         .PrintTitleColumns = ""
     
128.     End With
     
129.     ActiveSheet.PageSetup.PrintArea = ""
     
130.     With ActiveSheet.PageSetup
     
131.         .LeftHeader = ""
     
132.         .CenterHeader = ""
     
133.         .RightHeader = ""
     
134.         .LeftFooter = ""
     
135.         .CenterFooter = ""
     
136.         .RightFooter = ""
     
137.         .LeftMargin = Application.InchesToPoints(0.196850393700787)
     
138.         .RightMargin = Application.InchesToPoints(0.196850393700787)
     
139.         .TopMargin = Application.InchesToPoints(0.196850393700787)
     
140.         .BottomMargin = Application.InchesToPoints(0.196850393700787)
     
141.         .HeaderMargin = Application.InchesToPoints(0.511811023622047)
     
142.         .FooterMargin = Application.InchesToPoints(0.511811023622047)
     
143.         .PrintHeadings = False
     
144.         .PrintGridlines = False
     
145.         .PrintComments = xlPrintNoComments
     
146.         .PrintQuality = 600
     
147.         .CenterHorizontally = False
     
148.         .CenterVertically = False
     
149.         .Orientation = xlPortrait
     
150.         .Draft = False
     
151.         .PaperSize = xlPaperA4
     
152.         .FirstPageNumber = xlAutomatic
     
153.         .Order = xlDownThenOver
     
154.         .BlackAndWhite = False
     
155.         .Zoom = 100
     
156.         .PrintErrors = xlPrintErrorsDisplayed
     
157.     End With
     
158.    
     
159.     'A:F»¼¼W±Æ§Ç
     
160.     ActiveSheet.Columns("A:F").Select
     
161.     Selection.Sort Key1:=ActiveSheet.Range("C2"), Order1:=xlAscending, Header:=xlGuess, _
     
162.         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
     
163.         :=xlStroke, DataOption1:=xlSortNormal
     
164.    
     
165.     '¸ê®Æ­åªR
     
166.     ActiveSheet.Columns("D:D").Select
     
167.     Selection.Insert Shift:=xlToRight
     
168.     ActiveSheet.Columns("C:C").Select
     
169.     Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
     
170.         TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
     
171.         Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
     
172.         :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
     
173.         
     
174.     '¾ã²z
     
175.     ActiveSheet.Range("C1").Select
     
176.     ActiveCell.FormulaR1C1 = "µæ¦W"
     
177.     ActiveSheet.Range("D1").Select
     
178.     ActiveCell.FormulaR1C1 = "³æ»ù"
     
179.     ActiveSheet.Columns("D:D").ColumnWidth = 5.63
     
180.    
     
181.     Application.DisplayAlerts = True  '±Nĵ§i°T®§¥´¶}
     
182.    
     
183. Application.ScreenUpdating = True '¨ú®ø«Ì½ª«Ì¹õ¨ê·s
     
184. End Sub

½Æ»s¥N½X