Advertisement
Guest User

Untitled

a guest
Apr 26th, 2015
198
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 2.79 KB | None | 0 0
  1. Dim x As String
  2. Dim found As Boolean
  3. strFileFullName = ThisWorkbook.FullName
  4. strFileFullName = Replace(strFileFullName, ".xlsm", "")
  5. strFileFullName = strFileFullName + "_rejected.xlsx"
  6. ' MsgBox strFileFullName
  7. Set oExcel = CreateObject("Excel.Application")
  8. Set obook = oExcel.Workbooks.Add(1)
  9. Set oSheet = obook.Worksheets(1)
  10. oSheet.Name = "Results"
  11.  
  12. ' Select first line of data.
  13. Range("E2").Select
  14. ' Set search variable value.
  15. x = "rejected"
  16. ' Set Boolean variable "found" to false.
  17. found = False
  18. ' Set Do loop to stop at empty cell.
  19. Do Until IsEmpty(ActiveCell)
  20. ' Check active cell for search value.
  21. If ActiveCell.Value = "" Then
  22. Exit Do
  23. End If
  24. If ActiveCell.Value = x Then
  25. found = True
  26.  
  27. rowToCopy = ActiveCell.Row
  28. ActiveSheet.Rows(ActiveCell.Row).Select
  29. Selection.Copy
  30.  
  31. oSheet.Range("A1").Select
  32. lastrow = oSheet.Cells(Rows.Count, "B").End(xlUp).Row
  33. ' oSheet.Rows(1).Select.PasteSpcial
  34.  
  35. End If
  36. ' Step down 1 row from present location.
  37. ActiveCell.Offset(1, 0).Select
  38.  
  39. Loop
  40. ' Check for found.
  41. If found = True Then
  42. MsgBox "Value found in cell " & ActiveCell.Address
  43. Else
  44. MsgBox "Value not found"
  45. End If
  46. obook.SaveAs strFileFullName
  47. obook.Close
  48. End Sub
  49.  
  50. Sub AddWB()
  51. Dim nwBk As Workbook, WB As Workbook, Swb As String
  52. Dim Rws As Long, Rng As Range, c As Range, sh As Worksheet
  53.  
  54. Set WB = ThisWorkbook
  55. Set sh = WB.Worksheets("Sheet1")
  56.  
  57. Rws = sh.Cells(Rows.Count, "E").End(xlUp).Row
  58. Set Rng = Range(sh.Cells(2, 5), sh.Cells(Rws, 5))
  59.  
  60. Set nwBk = Workbooks.Add(1)
  61. Swb = WB.Path & "" & Mid(WB.Name, 1, Len(WB.Name) - 5) & ".xlsx"
  62. MsgBox Swb
  63.  
  64. For Each c In Rng.Cells
  65. If c = "x" Then c.EntireRow.Copy nwBk.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
  66. Next c
  67.  
  68. nwBk.SaveAs Filename:=Swb
  69.  
  70. End Sub
  71.  
  72. Sub CopyStuff()
  73. Dim SearchString As String
  74. Dim Found As Boolean
  75. Dim wsSource As Excel.Worksheet
  76. Dim wbTarget As Excel.Workbook
  77. Dim wsTarget As Excel.Worksheet
  78. Dim LastRow As Long
  79.  
  80. Set wsSource = ActiveSheet
  81. SearchString = "rejected"
  82. With wsSource
  83. Found = Application.WorksheetFunction.CountIf(.Range("E:E"), SearchString) > 0
  84. If Not Found Then
  85. MsgBox SearchString & " not found"
  86. Exit Sub
  87. End If
  88. Set wbTarget = Workbooks.Add(1)
  89. Set wsTarget = wbTarget.Worksheets(1)
  90. wsTarget.Name = "Results"
  91. .Range("E:E").AutoFilter
  92. LastRow = .Range("E" & .Rows.Count).End(xlUp).Row
  93. .Range("E:E").AutoFilter field:=1, Criteria1:=SearchString
  94. .Range("E1:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
  95. Destination:=wsTarget.Range("A1")
  96. End With
  97. wbTarget.SaveAs Replace(ThisWorkbook.FullName, ".xlsm", "_rejected.xlsx")
  98. wbTarget.Close
  99. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement