luhpro

Dear¤j¤j:

  °ÝÃD¡A¦p¦ó°Ñ¦Ò¤u§@ªí1¡A§¹¦¨¤u§@ªí2 ªºtable¡C

   ¥Ø«e·Q¨ì¥Î¸ê®Æ­åªR¡A¦ý¤£ª¾¦p¦ó§Ë?
...
jj369963 µoªí©ó 2014-9-4 17:06

1. Sub nn()
   
2.   Dim iCol%, iNum%, iSB%, iSE%, iTB%, iTE%
   
3.   Dim lSRow&, lTRow&
   
4.   Dim sStr1$, sStr2$, sStr$
   
5.   Dim vD
   
6.   Dim wsSou As Worksheet, wsTar As Worksheet
   
7.   
   
8.   Set vD = CreateObject("Scripting.Dictionary")
   
9.   Set wsSou = Sheets("¤u§@ªí1")
   
10.   Set wsTar = Sheets("¤u§@ªí2")
    
11.   lSRow = 1
    
12.   lTRow = 2
    
13.   iCol = 2
    
14.   With wsTar
    
15.     While .Cells(1, iCol) <> ""
    
16.       vD(CStr(.Cells(1, iCol))) = iCol
    
17.       iCol = iCol + 1
    
18.     Wend
    
19.     With wsSou
    
20.       While .Cells(lSRow, 1) <> ""
    
21.         wsTar.Cells(lTRow, 1) = .Cells(lSRow, 1)
    
22.         sStr1 = .Cells(lSRow, 2)
    
23.         sStr2 = .Cells(lSRow, 3)
    
24.       
    
25.         iSB = InStr(1, sStr1, "#") + 1
    
26.         iTB = InStr(1, sStr2, "#") + 1
    
27.         While iSB < Len(sStr1)
    
28.           iSE = InStr(iSB, sStr1, "#")
    
29.           If iSE = 0 Then iSE = Len(sStr1) + 1
    
30.           iTE = InStr(iTB, sStr2, "#")
    
31.           If iTE = 0 Then iTE = Len(sStr2) + 1
    
32.           wsTar.Cells(lTRow, vD(CStr(Application.Proper(Mid(sStr1, iSB, iSE - iSB))))) = Mid(sStr2, iTB, iTE - iTB)
    
33.           iSB = iSE + 1
    
34.           iTB = iTE + 1
    
35.         Wend
    
36.         lSRow = lSRow + 1
    
37.         lTRow = lTRow + 1
    
38.       Wend
    
39.     End With
    
40.   End With
    
41. End Sub

½Æ»s¥N½X

luhpro

¦^´_  luhpro
    Dear¤j¤j¡G
   ¦pªþ¾×¡A¸Ó¦p¦ó¼gVBA©O?
¦A·Ð½Ð«ü±Ð¡A·PÁÂ
jj369963 µoªí©ó 2014-9-20 23:36

1. Sub nn()
   
2.   Dim lRow&
   
3.   Dim wsTar As Worksheet
   
4.   
   
5.   Set wsTar = Sheets("Sheet2")
   
6.   wsTar.Cells.Clear
   
7.   With Sheets("Sheet1")
   
8.     .[B1].Copy wsTar.[B1]
   
9.     With wsTar.[B1]
   
10.       .TextToColumns Other:=True, OtherChar:="#"
    
11.       .Delete xlShiftToLeft
    
12.     End With
    
13.     lRow = 2
    
14.     Do While .Cells(lRow - 1, 3) <> ""
    
15.       .Cells(lRow - 1, 1).Copy wsTar.Cells(lRow, 1)
    
16.       .Cells(lRow - 1, 3).Copy wsTar.Cells(lRow, 2)
    
17.       With wsTar.Cells(lRow, 2)
    
18.         .TextToColumns Other:=True, OtherChar:="#"
    
19.         .Delete xlShiftToLeft
    
20.       End With
    
21.       lRow = lRow + 1
    
22.     Loop
    
23.   End With
    
24. End Sub

½Æ»s¥N½X

¸ê®Æ­åªR2-a.zip (16.4 KB)

¤U¸ü¦¸¼Æ: 2

2014-9-21 19:22