[µo°Ý] ¦p¦ó±q¸ê®Æ§¨ªºExcelŪÀɼgÀÉ

starbox520

¸ê®Æ§¨¸Ì¨C¤é³£·|·s¼W¤µ¤éªº¼Æ¾Ú
¤À§O¬°²Ä8Äæ¸ò²Ä19Äæ

¦pªG§Ú±o¸ê®Æ§¨¸ô®|¬OC:\Users\Rawdata

­n§â¸ê®Æ§¨¤ºªºÀÉ®×¥þ³¡¶]¤@¹M

¤À§O¨ú²Ä8Äæ¸ò²Ä19Äæ

ªþÀɦ³1­Ó¤ëªº¸ê®Æ

¤]¦³ªþ¤W§Ú¦X¨Ö°_¨Óªº®æ¦¡<¶]§¹ªºµ²ªG>

§Ú¥u¦³¨ú14¤Ñªº¸ê®Æ

½Ð°Ý¸Ó¦p¦ó°µ©O

¦]¬°§Ú¦³¤@¦~ªº¸ê®Æ­n¶]= " =

¤U¸ü (65.39 KB)

2016-12-19 09:58

tt1900.zip (589.85 KB)

¤U¸ü¦¸¼Æ: 11

2016-12-19 09:59

Hsieh

¦^´_ 1# starbox520

1. Sub inputraw()
   
2. ActiveSheet.UsedRange.Offset(1).ClearContents
   
3. Application.ScreenUpdating = False
   
4. fd = "C:\Users\Rawdata\" 'rawdataÀɮ׸ô®|
   
5. fs = Dir(fd & "*")
   
6. r = 2
   
7. Do Until fs = ""
   
8. With Workbooks.Open(fd & fs)
   
9.    ActiveSheet.Cells(r, 1).Resize(, 21) = .ActiveSheet.Cells(8, 1).Resize(, 21).Value
   
10.    ActiveSheet.Cells(r, 22).Resize(, 20) = .ActiveSheet.Cells(19, 2).Resize(, 20).Value
    
11.    .Close 0
    
12. End With
    
13. fs = Dir
    
14. r = r + 1
    
15. Loop
    
16. Application.ScreenUpdating = True
    
17. End Sub

½Æ»s¥N½X

starbox520

¦^´_ 2# Hsieh
¦^ª©¤j
§Ú¬O¥Î³oºØ¤èªk¥i¬O¦³«]­­¦bÁÙ­n³Ð¸ê®Æ§¨
ÁÙ¬O±zªº¦n¥Î«¢«¢

1. Sub test()
   
2.     Range("B2").Select
   
3.     ActiveWindow.FreezePanes = True
   
4.    
   
5. Dim p, f, arr1, arr2, arr3, arr4,  dic
   
6. Application.ScreenUpdating = False
   
7. Set dic = CreateObject("scripting.dictionary")
   
8. ActiveSheet.Range("B2:AO65535").ClearContents
   
9.     For j = 2 To ActiveSheet.Range("A1").CurrentRegion.Rows.Count
   
10.         dic(Cells(j, 1).Value) = j
    
11.     Next
    
12. 
    
13. p = ThisWorkbook.Path & "\rawdata\"
    
14. f = Dir(p & "*.xls")
    
15. 
    
16. Do While Len(f)
    
17.     If f <> "" Then
    
18.         With GetObject(p & f)
    
19.             arr1 = .Sheets(2).Range("A2:A8")
    
20.             arr2 = .Sheets(2).Range("B2:U8")
    
21.             arr3 = .Sheets(2).Range("A13:A19")
    
22.             arr4 = .Sheets(2).Range("B13:U19")
    
23.             .Close SaveChanges:=False
    
24.         End With
    
25.     End If
    
26.     With ThisWorkbook.ActiveSheet
    
27.         For i = 1 To 7
    
28.             If dic(arr1(i, 1)) <> "" Then
    
29.                 .Range("B" & dic(arr1(i, 1))).Resize(1, UBound(arr2, 2)).Value = WorksheetFunction.Index(arr2, i, 0)
    
30.                 'h1 = dic(arr2(i, 1))
    
31.             
    
32.             End If
    
33.             If dic(arr3(i, 1)) <> "" Then
    
34.                 .Range("v" & dic(arr3(i, 1))).Resize(1, UBound(arr4, 2)).Value = WorksheetFunction.Index(arr4, i, 0)
    
35.             End If
    
36.         Next
    
37.     End With
    
38.     f = Dir
    
39. Loop
    
40. Application.ScreenUpdating = True
    
41. End Sub

½Æ»s¥N½X