Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Dim x As String
- Dim found As Boolean
- strFileFullName = ThisWorkbook.FullName
- strFileFullName = Replace(strFileFullName, ".xlsm", "")
- strFileFullName = strFileFullName + "_rejected.xlsx"
- ' MsgBox strFileFullName
- Set oExcel = CreateObject("Excel.Application")
- Set obook = oExcel.Workbooks.Add(1)
- Set oSheet = obook.Worksheets(1)
- oSheet.Name = "Results"
- ' Select first line of data.
- Range("E2").Select
- ' Set search variable value.
- x = "rejected"
- ' Set Boolean variable "found" to false.
- found = False
- ' Set Do loop to stop at empty cell.
- Do Until IsEmpty(ActiveCell)
- ' Check active cell for search value.
- If ActiveCell.Value = "" Then
- Exit Do
- End If
- If ActiveCell.Value = x Then
- found = True
- rowToCopy = ActiveCell.Row
- ActiveSheet.Rows(ActiveCell.Row).Select
- Selection.Copy
- oSheet.Range("A1").Select
- lastrow = oSheet.Cells(Rows.Count, "B").End(xlUp).Row
- ' oSheet.Rows(1).Select.PasteSpcial
- End If
- ' Step down 1 row from present location.
- ActiveCell.Offset(1, 0).Select
- Loop
- ' Check for found.
- If found = True Then
- MsgBox "Value found in cell " & ActiveCell.Address
- Else
- MsgBox "Value not found"
- End If
- obook.SaveAs strFileFullName
- obook.Close
- End Sub
- Sub AddWB()
- Dim nwBk As Workbook, WB As Workbook, Swb As String
- Dim Rws As Long, Rng As Range, c As Range, sh As Worksheet
- Set WB = ThisWorkbook
- Set sh = WB.Worksheets("Sheet1")
- Rws = sh.Cells(Rows.Count, "E").End(xlUp).Row
- Set Rng = Range(sh.Cells(2, 5), sh.Cells(Rws, 5))
- Set nwBk = Workbooks.Add(1)
- Swb = WB.Path & "" & Mid(WB.Name, 1, Len(WB.Name) - 5) & ".xlsx"
- MsgBox Swb
- For Each c In Rng.Cells
- If c = "x" Then c.EntireRow.Copy nwBk.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
- Next c
- nwBk.SaveAs Filename:=Swb
- End Sub
- Sub CopyStuff()
- Dim SearchString As String
- Dim Found As Boolean
- Dim wsSource As Excel.Worksheet
- Dim wbTarget As Excel.Workbook
- Dim wsTarget As Excel.Worksheet
- Dim LastRow As Long
- Set wsSource = ActiveSheet
- SearchString = "rejected"
- With wsSource
- Found = Application.WorksheetFunction.CountIf(.Range("E:E"), SearchString) > 0
- If Not Found Then
- MsgBox SearchString & " not found"
- Exit Sub
- End If
- Set wbTarget = Workbooks.Add(1)
- Set wsTarget = wbTarget.Worksheets(1)
- wsTarget.Name = "Results"
- .Range("E:E").AutoFilter
- LastRow = .Range("E" & .Rows.Count).End(xlUp).Row
- .Range("E:E").AutoFilter field:=1, Criteria1:=SearchString
- .Range("E1:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
- Destination:=wsTarget.Range("A1")
- End With
- wbTarget.SaveAs Replace(ThisWorkbook.FullName, ".xlsm", "_rejected.xlsx")
- wbTarget.Close
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement