Apply macros to an other workbook

[teodormircea]

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(xlCellTypeAllFormatConditions).Clear
    On Error GoTo 0
End Sub

[MaximS]

Post both files working and not working plus some objectives regarding to goals you trying to archive.

It's pretty hard to find out what code suppose to do when you cannot see the data which macro is proccessing.

[teodormircea]

OK.

This macro works like an autofilter , i choose a column then for this column i choose criterias, and i can continue to a choose an other columns apply other criterias, and so on. At the end a new file is created named after the chosen criterias and saved in the folder were this workbook exist.

[MaximS]

The problem is without seeing both files it's impossible to find the difference, analize the code and adjust to your needs.

[Tom527]

The problem is "ThisWorkbook.Activate", this activates the workbook the macro code is located. You have to remove "ThisWorkbook" reference, try changing to activeworkbook