register313

¦^´_ 1# marklos

1. Sub xx()
   
2. For d = [a1].End(xlDown).Row To 2 Step -1
   
3.   If Cells(d, 4) <> "" Then
   
4.      Rows(d + 1).Insert
   
5.      Cells(d, 4).Copy Cells(d + 1, 3)
   
6.      For i = 1 To 10
   
7.        If Cells(d + 1, i) = "" Then Range(Cells(d + 1, i), Cells(d, i)).Merge
   
8.      Next i
   
9.   End If
   
10. Next d
    
11. Columns(4).Delete
    
12. End Sub

½Æ»s¥N½X

register313

¦^´_ 5# marklos

1. Sub xx()
   
2. Sheets("sheet1").Cells.Copy Sheets("sheet2").[A1]
   
3. Sheets("sheet2").Select
   
4. For d = [A1].End(xlDown).Row To 2 Step -1
   
5.   c = Application.CountA(Cells(d, 4).Resize(1, 2))
   
6.   If Cells(d, 4) <> "" Then
   
7.      Rows(d).Copy
   
8.      Rows(d + 1).Resize(c).Insert Shift:=xlDown
   
9.      Cells(d + 1, 3).Resize(c, 1) = Application.Transpose(Cells(d, 4).Resize(1, 2))
   
10.   End If
    
11. Next d
    
12. Columns("d:e").Delete
    
13. End Sub

½Æ»s¥N½X

1. Sub yy()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. With Sheets("sheet1")
   
4.   For i = 2 To .[A1].End(xlDown).Row
   
5.     Ar = .Range(.Cells(i, "A"), .Cells(i, "K"))
   
6.     d(.Cells(i, 3).Value) = Ar
   
7.     For j = 4 To 5
   
8.       If .Cells(i, j) <> "" Then
   
9.         Ar(1, 3) = .Cells(i, j)
   
10.         d(.Cells(i, j).Value) = Ar
    
11.       End If
    
12.     Next j
    
13.   Next i
    
14. End With
    
15. With Sheets("sheet2")
    
16.   .Cells = ""
    
17.   Sheets("sheet1").Rows(1).Copy .[A1]
    
18.   .[A2].Resize(d.Count, 11) = Application.Transpose(Application.Transpose(d.items))
    
19.   .Columns("D:E").Delete
    
20.   .[A1].CurrentRegion.Borders.LineStyle = xlContinuous
    
21. End With
    
22. End Sub

½Æ»s¥N½X