PDA

View Full Version : Apply macros to an other workbook



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

MaximS
09-30-2008, 07:10 AM
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
09-30-2008, 08:08 AM
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
09-30-2008, 08:47 AM
The problem is without seeing both files it's impossible to find the difference, analize the code and adjust to your needs.

Tom527
09-30-2008, 11:37 AM
The problem is "ThisWorkbook.Activate", this activates the workbook the macro code is located. You have to remove "ThisWorkbook" reference, try changing to activeworkbook