teodormircea
09-30-2008, 06:26 AM
This code is working only on the workbook that have the code. if i'm trying to apply the code to an other workbook it doesn't work
Option Explicit
Dim varColumn As Variant
Dim wkbBook As Workbook
Dim strName() As String
Dim strTMP() As String
Sub Create_New()
Dim blnCount As Boolean
Dim varText As Variant
Dim varXLS As Variant
Dim lngTMP1 As Long
Dim lngTMP As Long
On Error GoTo Create_New_Error
Do
lngTMP = 0
Erase strTMP
ThisWorkbook.Activate
Application.ScreenUpdating = True
Set varColumn = Application.InputBox("Click Cell in Column OR Cancel to Quit", "Column", , , , , , 8)
Call Set_empty(varColumn.Column)
Do
varText = Application.InputBox("Click Cell - Criteria", "Criteria", , , , , , 8)
ReDim Preserve strTMP(lngTMP)
ReDim Preserve strName(lngTMP1)
strTMP(lngTMP) = varText
strName(lngTMP1) = varText
If varText = False Then Exit Sub
lngTMP1 = lngTMP1 + 1
lngTMP = lngTMP + 1
blnCount = IIf((MsgBox("Next Criteria?", vbYesNo + vbQuestion, "Criteria") = vbYes), False, True)
Loop Until varText <> "" And blnCount = True
If Not varText <> "" Or varText = False Then Exit Sub
Call Search_Copy
Loop Until varColumn = False
On Error GoTo 0
Exit Sub
Create_New_Error:
If Err.Number = 13 Then
If lngTMP1 = 0 Then Exit Sub
If wkbBook.Name <> "" Then
varXLS = Join(strName, ".")
wkbBook.SaveAs (ThisWorkbook.Path & "\" & varXLS & ".xls")
wkbBook.Close False
Else
wkbBook.Close False
End If
Else
Application.ScreenUpdating = True: Exit Sub
End If
Call Delete_empty(varColumn.Column)
Application.ScreenUpdating = True
End Sub
Public Sub Search_Copy()
Dim wksSheet As Worksheet
Dim wksSheetZ As Worksheet
Dim intCount As Integer
Dim strSearch As String
Dim strFirst As String
Dim rngFound As Range
Application.ScreenUpdating = False
On Error Resume Next
Set wksSheet = ThisWorkbook.Worksheets(1) ' adapt
If wkbBook.Name = "" Then
Set wksSheetZ = ThisWorkbook.Worksheets(1)
Set wkbBook = Workbooks.Add(xlWBATWorksheet)
wksSheet.Rows(1).Copy
ActiveSheet.Rows(1).Insert (xlShiftDown)
Else
wkbBook.Activate
wkbBook.Worksheets.Add
Set wksSheetZ = wkbBook.Worksheets(2)
wksSheet.Rows(1).Copy
ActiveSheet.Rows(1).Insert (xlShiftDown)
End If
On Error GoTo 0
For intCount = 0 To UBound(strTMP)
If strTMP(intCount) = "empty" Then strSearch = "empty" Else: strSearch = strTMP(intCount)
Set rngFound = wksSheetZ.Columns(varColumn.Column).Find(strSearch, _
LookIn:=xlValues, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
wksSheetZ.Rows(rngFound.Row).Copy
ActiveSheet.Rows(Sheets(1).Cells. _
SpecialCells(xlLastCell).Row + 1).Insert (xlShiftDown)
Application.CutCopyMode = False
Set rngFound = wksSheetZ.Columns(varColumn.Column).FindNext(After:=rngFound)
If rngFound.Address = strFirst Then Exit Do
Loop
Else
MsgBox "Nothing found!"
End If
Next intCount
Call Delete_empty(varColumn.Column)
End Sub
Sub Set_empty(ByVal intColumn As Integer)
On Error Resume Next
With ActiveSheet.UsedRange.Columns(intColumn).SpecialCells(xlCellTypeBlanks)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="=""H2SO4"""
'.FormatConditions(1).Interior.ColorIndex = 15
.FormulaR1C1 = "empty"
End With
On Error GoTo 0
End Sub
Sub Delete_empty(ByVal intColumn As Integer)
On Error Resume Next
ActiveSheet.UsedRange.Columns(intColumn).SpecialCells(xlCellTypeAllFormatCo nditions).Clear
On Error GoTo 0
End Sub
Option Explicit
Dim varColumn As Variant
Dim wkbBook As Workbook
Dim strName() As String
Dim strTMP() As String
Sub Create_New()
Dim blnCount As Boolean
Dim varText As Variant
Dim varXLS As Variant
Dim lngTMP1 As Long
Dim lngTMP As Long
On Error GoTo Create_New_Error
Do
lngTMP = 0
Erase strTMP
ThisWorkbook.Activate
Application.ScreenUpdating = True
Set varColumn = Application.InputBox("Click Cell in Column OR Cancel to Quit", "Column", , , , , , 8)
Call Set_empty(varColumn.Column)
Do
varText = Application.InputBox("Click Cell - Criteria", "Criteria", , , , , , 8)
ReDim Preserve strTMP(lngTMP)
ReDim Preserve strName(lngTMP1)
strTMP(lngTMP) = varText
strName(lngTMP1) = varText
If varText = False Then Exit Sub
lngTMP1 = lngTMP1 + 1
lngTMP = lngTMP + 1
blnCount = IIf((MsgBox("Next Criteria?", vbYesNo + vbQuestion, "Criteria") = vbYes), False, True)
Loop Until varText <> "" And blnCount = True
If Not varText <> "" Or varText = False Then Exit Sub
Call Search_Copy
Loop Until varColumn = False
On Error GoTo 0
Exit Sub
Create_New_Error:
If Err.Number = 13 Then
If lngTMP1 = 0 Then Exit Sub
If wkbBook.Name <> "" Then
varXLS = Join(strName, ".")
wkbBook.SaveAs (ThisWorkbook.Path & "\" & varXLS & ".xls")
wkbBook.Close False
Else
wkbBook.Close False
End If
Else
Application.ScreenUpdating = True: Exit Sub
End If
Call Delete_empty(varColumn.Column)
Application.ScreenUpdating = True
End Sub
Public Sub Search_Copy()
Dim wksSheet As Worksheet
Dim wksSheetZ As Worksheet
Dim intCount As Integer
Dim strSearch As String
Dim strFirst As String
Dim rngFound As Range
Application.ScreenUpdating = False
On Error Resume Next
Set wksSheet = ThisWorkbook.Worksheets(1) ' adapt
If wkbBook.Name = "" Then
Set wksSheetZ = ThisWorkbook.Worksheets(1)
Set wkbBook = Workbooks.Add(xlWBATWorksheet)
wksSheet.Rows(1).Copy
ActiveSheet.Rows(1).Insert (xlShiftDown)
Else
wkbBook.Activate
wkbBook.Worksheets.Add
Set wksSheetZ = wkbBook.Worksheets(2)
wksSheet.Rows(1).Copy
ActiveSheet.Rows(1).Insert (xlShiftDown)
End If
On Error GoTo 0
For intCount = 0 To UBound(strTMP)
If strTMP(intCount) = "empty" Then strSearch = "empty" Else: strSearch = strTMP(intCount)
Set rngFound = wksSheetZ.Columns(varColumn.Column).Find(strSearch, _
LookIn:=xlValues, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
wksSheetZ.Rows(rngFound.Row).Copy
ActiveSheet.Rows(Sheets(1).Cells. _
SpecialCells(xlLastCell).Row + 1).Insert (xlShiftDown)
Application.CutCopyMode = False
Set rngFound = wksSheetZ.Columns(varColumn.Column).FindNext(After:=rngFound)
If rngFound.Address = strFirst Then Exit Do
Loop
Else
MsgBox "Nothing found!"
End If
Next intCount
Call Delete_empty(varColumn.Column)
End Sub
Sub Set_empty(ByVal intColumn As Integer)
On Error Resume Next
With ActiveSheet.UsedRange.Columns(intColumn).SpecialCells(xlCellTypeBlanks)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="=""H2SO4"""
'.FormatConditions(1).Interior.ColorIndex = 15
.FormulaR1C1 = "empty"
End With
On Error GoTo 0
End Sub
Sub Delete_empty(ByVal intColumn As Integer)
On Error Resume Next
ActiveSheet.UsedRange.Columns(intColumn).SpecialCells(xlCellTypeAllFormatCo nditions).Clear
On Error GoTo 0
End Sub