Pastebin launched a little side project called VERYVIRAL.com, check it out ;-) Want more features on Pastebin? Sign Up, it's FREE!
Guest

Untitled

By: a guest on Apr 19th, 2012  |  syntax: VisualBasic  |  size: 6.34 KB  |  views: 28  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. Sub customcopy()
  2.  
  3. Application.ScreenUpdating = False
  4. Dim lastLine As Long
  5. Dim findWhat As String
  6. Dim toCopy As Boolean
  7. Dim cell As Range
  8. Dim i As Long
  9. Dim j As Long
  10.  
  11. findWhat = "Committee I "
  12. lastLine = ActiveSheet.UsedRange.Rows.Count
  13.  
  14. j = 1
  15. For i = 1 To lastLine
  16.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  17.         If InStr(cell.Text, findWhat) <> 0 Then
  18.             toCopy = True
  19.         End If
  20.     Next
  21.     If toCopy = True Then
  22.         Rows(i).Copy Destination:=Sheets("Committee I").Rows(j)
  23.         j = j + 1
  24.     End If
  25.     toCopy = False
  26. Next
  27.  
  28.  
  29. findWhat = "Committee II "
  30. lastLine = ActiveSheet.UsedRange.Rows.Count
  31.  
  32. j = 1
  33. For i = 1 To lastLine
  34.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  35.         If InStr(cell.Text, findWhat) <> 0 Then
  36.             toCopy = True
  37.         End If
  38.     Next
  39.     If toCopy = True Then
  40.         Rows(i).Copy Destination:=Sheets("Committee II").Rows(j)
  41.         j = j + 1
  42.     End If
  43.     toCopy = False
  44. Next
  45.  
  46. findWhat = "Committee III "
  47. lastLine = ActiveSheet.UsedRange.Rows.Count
  48.  
  49. j = 1
  50. For i = 1 To lastLine
  51.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  52.         If InStr(cell.Text, findWhat) <> 0 Then
  53.             toCopy = True
  54.         End If
  55.     Next
  56.     If toCopy = True Then
  57.         Rows(i).Copy Destination:=Sheets("Committee III").Rows(j)
  58.         j = j + 1
  59.     End If
  60.     toCopy = False
  61. Next
  62.  
  63. findWhat = "Committee IV "
  64. lastLine = ActiveSheet.UsedRange.Rows.Count
  65.  
  66. j = 1
  67. For i = 1 To lastLine
  68.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  69.         If InStr(cell.Text, findWhat) <> 0 Then
  70.             toCopy = True
  71.         End If
  72.     Next
  73.     If toCopy = True Then
  74.         Rows(i).Copy Destination:=Sheets("Committee IV").Rows(j)
  75.         j = j + 1
  76.     End If
  77.     toCopy = False
  78. Next
  79.  
  80. findWhat = "Committee V "
  81. lastLine = ActiveSheet.UsedRange.Rows.Count
  82.  
  83. j = 1
  84. For i = 1 To lastLine
  85.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  86.         If InStr(cell.Text, findWhat) <> 0 Then
  87.             toCopy = True
  88.         End If
  89.     Next
  90.     If toCopy = True Then
  91.         Rows(i).Copy Destination:=Sheets("Committee V").Rows(j)
  92.         j = j + 1
  93.     End If
  94.     toCopy = False
  95. Next
  96.  
  97. findWhat = "Committee VI "
  98. lastLine = ActiveSheet.UsedRange.Rows.Count
  99.  
  100. j = 1
  101. For i = 1 To lastLine
  102.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  103.         If InStr(cell.Text, findWhat) <> 0 Then
  104.             toCopy = True
  105.         End If
  106.     Next
  107.     If toCopy = True Then
  108.         Rows(i).Copy Destination:=Sheets("Committee VI").Rows(j)
  109.         j = j + 1
  110.     End If
  111.     toCopy = False
  112. Next
  113.  
  114. findWhat = "Committee VII "
  115. lastLine = ActiveSheet.UsedRange.Rows.Count
  116.  
  117. j = 1
  118. For i = 1 To lastLine
  119.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  120.         If InStr(cell.Text, findWhat) <> 0 Then
  121.             toCopy = True
  122.         End If
  123.     Next
  124.     If toCopy = True Then
  125.         Rows(i).Copy Destination:=Sheets("Committee VII").Rows(j)
  126.         j = j + 1
  127.     End If
  128.     toCopy = False
  129. Next
  130.  
  131. findWhat = "Committee VIII "
  132. lastLine = ActiveSheet.UsedRange.Rows.Count
  133.  
  134. j = 1
  135. For i = 1 To lastLine
  136.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  137.         If InStr(cell.Text, findWhat) <> 0 Then
  138.             toCopy = True
  139.         End If
  140.     Next
  141.     If toCopy = True Then
  142.         Rows(i).Copy Destination:=Sheets("Committee VIII").Rows(j)
  143.         j = j + 1
  144.     End If
  145.     toCopy = False
  146. Next
  147.  
  148. findWhat = "Committee IX "
  149. lastLine = ActiveSheet.UsedRange.Rows.Count
  150.  
  151. j = 1
  152. For i = 1 To lastLine
  153.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  154.         If InStr(cell.Text, findWhat) <> 0 Then
  155.             toCopy = True
  156.         End If
  157.     Next
  158.     If toCopy = True Then
  159.         Rows(i).Copy Destination:=Sheets("Committee IX").Rows(j)
  160.         j = j + 1
  161.     End If
  162.     toCopy = False
  163. Next
  164.  
  165. findWhat = "Committee X "
  166. lastLine = ActiveSheet.UsedRange.Rows.Count
  167.  
  168. j = 1
  169. For i = 1 To lastLine
  170.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  171.         If InStr(cell.Text, findWhat) <> 0 Then
  172.             toCopy = True
  173.         End If
  174.     Next
  175.     If toCopy = True Then
  176.         Rows(i).Copy Destination:=Sheets("Committee X").Rows(j)
  177.         j = j + 1
  178.     End If
  179.     toCopy = False
  180. Next
  181.  
  182. findWhat = "Committee XI "
  183. lastLine = ActiveSheet.UsedRange.Rows.Count
  184.  
  185. j = 1
  186. For i = 1 To lastLine
  187.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  188.         If InStr(cell.Text, findWhat) <> 0 Then
  189.             toCopy = True
  190.         End If
  191.     Next
  192.     If toCopy = True Then
  193.         Rows(i).Copy Destination:=Sheets("Committee XI").Rows(j)
  194.         j = j + 1
  195.     End If
  196.     toCopy = False
  197. Next
  198.  
  199. findWhat = "Committee XII "
  200. lastLine = ActiveSheet.UsedRange.Rows.Count
  201.  
  202. j = 1
  203. For i = 1 To lastLine
  204.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  205.         If InStr(cell.Text, findWhat) <> 0 Then
  206.             toCopy = True
  207.         End If
  208.     Next
  209.     If toCopy = True Then
  210.         Rows(i).Copy Destination:=Sheets("Committee XII").Rows(j)
  211.         j = j + 1
  212.     End If
  213.     toCopy = False
  214. Next
  215.  
  216. findWhat = "Committee XIII "
  217. lastLine = ActiveSheet.UsedRange.Rows.Count
  218.  
  219. j = 1
  220. For i = 1 To lastLine
  221.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  222.         If InStr(cell.Text, findWhat) <> 0 Then
  223.             toCopy = True
  224.         End If
  225.     Next
  226.     If toCopy = True Then
  227.         Rows(i).Copy Destination:=Sheets("Committee XIII").Rows(j)
  228.         j = j + 1
  229.     End If
  230.     toCopy = False
  231. Next
  232.  
  233. findWhat = "Committee XIV "
  234. lastLine = ActiveSheet.UsedRange.Rows.Count
  235.  
  236. j = 1
  237. For i = 1 To lastLine
  238.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  239.         If InStr(cell.Text, findWhat) <> 0 Then
  240.             toCopy = True
  241.         End If
  242.     Next
  243.     If toCopy = True Then
  244.         Rows(i).Copy Destination:=Sheets("Committee XIV").Rows(j)
  245.         j = j + 1
  246.     End If
  247.     toCopy = False
  248. Next
  249.  
  250. findWhat = "Committee XV "
  251. lastLine = ActiveSheet.UsedRange.Rows.Count
  252.  
  253. j = 1
  254. For i = 1 To lastLine
  255.     For Each cell In Range("F1:Q1").Offset(i - 1, 0)
  256.         If InStr(cell.Text, findWhat) <> 0 Then
  257.             toCopy = True
  258.         End If
  259.     Next
  260.     If toCopy = True Then
  261.         Rows(i).Copy Destination:=Sheets("Committee XV").Rows(j)
  262.         j = j + 1
  263.     End If
  264.     toCopy = False
  265. Next
  266.  
  267. i = MsgBox(((j - 1) & " row(s) were copied!"), vbOKOnly, "Result")
  268.  
  269. Application.ScreenUpdating = True
  270. End Sub
clone this paste RAW Paste Data