daily pastebin goal
22%
SHARE
TWEET

Untitled

a guest Apr 16th, 2018 59 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub Macro1()
  2. Dim range As range
  3. Dim i As Integer
  4.  
  5. Dim RowCount As Integer
  6. Dim ColumnCount As Integer
  7. Dim sheet As worksheet
  8. Dim tempRange As range
  9. Dim valueRange As range
  10. Dim insertRange As range
  11.  
  12.     Set range = Selection
  13.     RowCount = range.Rows.Count
  14.     ColumnCount = range.Columns.Count
  15.     For i = 1 To RowCount
  16.         Set sheet = ActiveSheet
  17.  
  18.         Set valueRange = sheet.range("A" & (((i - 1) * 4) + 1), "E" & (((i - 1) * 4) + 1))
  19.  
  20.         Set tempRange = sheet.range("A" & (((i - 1) * 4) + 2), "E" & (((i - 1) * 4) + 2))
  21.         tempRange.Select
  22.         tempRange.Insert xlShiftDown
  23.         Set insertRange = Selection
  24.         insertRange.Cells(1, 1) = valueRange.Cells(1, 1)
  25.         insertRange.Cells(1, 2) = valueRange.Cells(1, 3)
  26.         valueRange.Cells(1, 3) = ""
  27.  
  28.         Set tempRange = sheet.range("A" & (((i - 1) * 4) + 3), "E" & (((i - 1) * 4) + 3))
  29.         tempRange.Select
  30.         tempRange.Insert xlShiftDown
  31.         Set insertRange = Selection
  32.         insertRange.Cells(1, 1) = valueRange.Cells(1, 1)
  33.         insertRange.Cells(1, 2) = valueRange.Cells(1, 4)
  34.         valueRange.Cells(1, 4) = ""
  35.  
  36.         Set tempRange = sheet.range("A" & (((i - 1) * 4) + 4), "E" & (((i - 1) * 4) + 4))
  37.         tempRange.Select
  38.         tempRange.Insert xlShiftDown
  39.         Set insertRange = Selection
  40.         insertRange.Cells(1, 1) = valueRange.Cells(1, 1)
  41.         insertRange.Cells(1, 2) = valueRange.Cells(1, 5)
  42.         valueRange.Cells(1, 5) = ""
  43.  
  44.     Next i
  45. End Sub
  46.    
  47. Dim cn As Object
  48. Dim rs As Object
  49.  
  50. strFile = Workbooks(1).FullName
  51. strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
  52.     & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
  53.  
  54. Set cn = CreateObject("ADODB.Connection")
  55. Set rs = CreateObject("ADODB.Recordset")
  56.  
  57. cn.Open strCon
  58.  
  59. strSQL = "SELECT t.F1, t.Col2 FROM (" _
  60.        & "SELECT F1, 1 As Sort, F3 As Col2 FROM [Sheet1$] " _
  61.        & "UNION ALL " _
  62.        & "SELECT F1, 2 As Sort, F4 As Col2 FROM [Sheet1$] " _
  63.        & "UNION ALL " _
  64.        & "SELECT F1, 3 As Sort, F5 As Col2 FROM [Sheet1$] ) As t " _
  65.        & "ORDER BY F1, Sort"
  66.  
  67. rs.Open strSQL, cn
  68.  
  69. Worksheets("Sheet6").Cells(2, 1).CopyFromRecordset rs
  70.    
  71. Public Sub splurge(ByVal sht As Worksheet)
  72.  
  73.     Dim rw As Long
  74.     Dim i As Long
  75.  
  76.     For rw = sht.UsedRange.Rows.Count To 1 Step -1
  77.         With sht
  78.             Range(.Rows(rw + 1), .Rows(rw + 3)).Insert
  79.             For i = 1 To 3
  80.                 ' copy column 1 into each new row
  81.                 .Cells(rw, 1).Copy .Cells(rw + i, 1)
  82.                 ' cut column 3,4,5 and paste to col 2 on next rows
  83.                 .Cells(rw, 2 + i).Cut .Cells(rw + i, 2)
  84.             Next i
  85.         End With
  86.     Next rw
  87.  
  88. End Sub
RAW Paste Data
Top