Hi all,
I have a source workbook with several data and formulas. One of the formula is referencing the second sheet named "Guidelines". I create several new workbooks from the original data based on some assumptions. Everything works fine, workbooks and data are created and saved smoothly in a new folder named Bonus. The only problem is that the formula I mentioned before still references the source workbook, which i don't want. The original workbook name is included in the formula. I've tried several solutions but never managed to break the link to the original workbook.
Three of the solutions i tried follows:
A dialog box always appears asking me to select a file.
The formula I dont want to reference to the original workbook is in column Z.
The full code is provided below. I use two subs one named "CreateUniqueArrays" and the second "MainSub" which calls the "CreateUniqueArrays". Comment out in the MainSub is the solutions posted before. I even tried to hardcode the formula inside the vba code declaring a constant and use it later on but still doesnt work.
I cannot attach the workbook which would have been more meaningful for you.
Any help will be appreciated
Thanks in advance
George
I have a source workbook with several data and formulas. One of the formula is referencing the second sheet named "Guidelines". I create several new workbooks from the original data based on some assumptions. Everything works fine, workbooks and data are created and saved smoothly in a new folder named Bonus. The only problem is that the formula I mentioned before still references the source workbook, which i don't want. The original workbook name is included in the formula. I've tried several solutions but never managed to break the link to the original workbook.
Three of the solutions i tried follows:
VBA Code:
Dim cell As Range
For Each cell In .Range("z8:z" & lastrow)
cell.Formula = Replace(cell.Formula, "[" & ThisWorkbook.Name & "]", "")
Next cell
VBA Code:
For k = 1 To lastrow
DestWs.Range("z" & k).Value = ""
Next k
DestWs.Range("z9").Formula = myFormula
DestWs.Range("z9:z" & lastrow).FillDown
VBA Code:
For k = 1 To lastrow
DestWs.Range("z" & k).Formula = Replace(DestWs.Range("z" & k).Formula, "[" & ThisWorkbook.Name & "]", "")
Next kA dialog box always appears asking me to select a file.
The formula I dont want to reference to the original workbook is in column Z.
The full code is provided below. I use two subs one named "CreateUniqueArrays" and the second "MainSub" which calls the "CreateUniqueArrays". Comment out in the MainSub is the solutions posted before. I even tried to hardcode the formula inside the vba code declaring a constant and use it later on but still doesnt work.
VBA Code:
Option Explicit
Public uniqueNames() As String
Sub UniqueNamesToArray()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim i As Integer, j As Integer
Dim found As Boolean
Dim colLetter As String
' Set the worksheet
Set ws = cnOutput
'Prompt the user to enter the column letter
colLetter = InputBox("Enter the column letter (e.g., 'B'):", "Column Selection")
' Set the range to the column B
Set rng = ws.Range(colLetter & "9:" & colLetter & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row) 'Start at row 9
' Resize the array to fit all possible unique names
ReDim uniqueNames(1 To rng.Rows.Count)
' Initialize index for uniqueNames array
i = 0
' Loop through each cell in the range
For Each cell In rng
' Check if the cell value is not empty
If cell.Value <> "" Then
' Check if the cell value is unique
found = False
For j = 1 To i
If uniqueNames(j) = cell.Value Then
found = True
Exit For
End If
Next j
' If the value is unique, add it to the uniqueNames array
If Not found Then
i = i + 1
uniqueNames(i) = cell.Value
End If
End If
Next cell
' Resize the array to fit only the unique names
ReDim Preserve uniqueNames(1 To i)
' Output the unique names to Immediate window
For j = 1 To i
Debug.Print uniqueNames(j)
Next j
End Sub
VBA Code:
Option Explicit
Sub GetUniqueNames()
'----------------------------------------------
'Find Unique Names in Columns B and C
'to filter out during the process
'---------------------------------------------
Dim LrowB As Integer 'Last row in col B
Dim LrowC As Integer 'Last row in col C
Dim i As Integer
Dim j As Integer
Dim savePath As String
Dim wb As Workbook
Dim ws As Worksheet
Dim sheetProtection As Boolean
'Dim hiddenColumns As Range
Application.ScreenUpdating = False
LrowB = cnOutput.Cells(Rows.Count, 2).End(xlUp).Row
LrowC = cnOutput.Cells(Rows.Count, 3).End(xlUp).Row
' Set the worksheet
Set ws = cnOutput
' Store the current protection status
sheetProtection = ws.ProtectContents
'Unprotect the sheet
cnOutput.Unprotect Password:="1234"
'------------------------------------------------------------------------------------------------------------------------------
'CODE FOR OWNERS
For j = 1 To 2
'Create Chiefs array - Column B
Call UniqueNamesToArray
'Loop through employees
For i = LBound(uniqueNames) To UBound(uniqueNames)
' Unhide columns AA and AB
ws.Columns("AA:AB").Hidden = False
'Select correct number of rows according to user's input box value for column choice
If j = 1 Then
' Apply AutoFilter for each value in the uniqueNames array
cnOutput.Range("a8").AutoFilter Field:=2, Criteria1:=uniqueNames(i)
Range("a1:ac" & LrowB).Select
Else
' Apply AutoFilter for each value in the uniqueNames array
cnOutput.Range("a8").AutoFilter Field:=3, Criteria1:=uniqueNames(i)
Range("a1:ac" & LrowC).Select
End If
'Copy data
Selection.Copy
'Create new workbook and paste the data
Set wb = Workbooks.Add
Range("a1").Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'------------------------------------------------------------------------------------------------------------------------------------------------------------
' 'Correct formulas
' Dim srcWorksheet As Worksheet
' Dim cell As Range
' Dim lastrow As Integer
' Dim srcSheetName As String
' Dim destSheetName As String
' Dim DestWs As Worksheet
' Set srcWorksheet = ThisWorkbook.Sheets("Guidelines")
' srcSheetName = srcWorksheet.Name
' destSheetName = "Guidelines"
' Dim k As Integer
' Dim myFormula As String
'
' ' Define the formula
' myFormula = "=IF(ISNA(MATCH(I9,Guidelines!$J$3:$J$12,0)),IFERROR(IF(D9=""Included"",IF(W9>INDEX(Guidelines!$C$23:$H$26,MATCH(Output!R9,Guidelines!$B$23:$B$26,0),MATCH(Output!Q9,Guidelines!$C$22:$H$22,0)),""The proposal is above the max threshold. Please revise."",""Ok""),""""),""-"")"
' myFormula = myFormula & ",IFERROR(IF(D9=""Included"",IF(W9>INDEX(Guidelines!$C$52:$H$55,MATCH(Output!R9,Guidelines!$B$52:$B$55,0),MATCH(Output!Q9,Guidelines!$C$51:$H$51,0)),""The proposal is above the max threshold. Please revise."",""Ok""),""""),""-""))"
'
'
' Set DestWs = wb.Sheets(1)
' With DestWs
' lastrow = .Cells(Rows.Count, "Z").End(xlUp).Row
' End With
'
'
' For k = 1 To lastrow
' DestWs.Range("z" & k).Value = ""
' Next k
'
' DestWs.Range("z9").Formula = myFormula
' DestWs.Range("z9:z" & lastrow).FillDown
'
' For k = 1 To lastrow
' DestWs.Range("z" & k).Formula = Replace(DestWs.Range("z" & k).Formula, "[" & ThisWorkbook.Name & "]", "")
' Next k
' Dim cell As Range
' For Each cell In .Range("z8:z" & lastrow)
' cell.Formula = Replace(cell.Formula, "[" & ThisWorkbook.Name & "]", "")
' Next cell
'End With
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Copy sheets from original workbook to new workbook
ThisWorkbook.Sheets(Array("Guidelines", "Definitions")).Copy After:=wb.Sheets(wb.Sheets.Count)
wb.Sheets(1).Activate
With wb.Sheets(1)
'Autofit columns
.Columns("A:AC").AutoFit
'Hide again columns AA and AB
.Columns("AA:AB").Hidden = True
'Enable autofilter
.Range("A8:AC8").AutoFilter Field:=1
End With
With ActiveWindow
'Remove Gridlines
.DisplayGridlines = False
'Freeze Col 5 Row 9
If .FreezePanes Then .FreezePanes = False
.SplitColumn = 5
.SplitRow = 9
.FreezePanes = True
End With
'Protect the first worksheet of the new workbook with password 1234
With wb.Sheets(1)
.Protect Password:="1234", _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
AllowFormattingCells:=True, _
AllowFormattingColumns:=True, _
AllowFormattingRows:=True, _
AllowInsertingColumns:=False, _
AllowInsertingRows:=False, _
AllowDeletingColumns:=False, _
AllowDeletingRows:=False, _
AllowSorting:=True, _
AllowFiltering:=True, _
AllowUsingPivotTables:=True, _
UserInterfaceOnly:=True
End With
' Save the workbook with the employee's name and current date/time
savePath = ThisWorkbook.Path & "\Bonus\" & uniqueNames(i) & " " & Format(Now(), "yyyy-mm-dd_hh-mm-ss") & ".xlsx"
wb.SaveAs savePath
wb.Close False
'Return
ThisWorkbook.Activate
Application.CutCopyMode = False
' Clear the filter
cnOutput.UsedRange.AutoFilter
Next i
' Protect the sheet again with code 1234 if it was protected before
If sheetProtection Then
ws.Protect "1234"
End If
cnOutput.Activate
cnOutput.Range("A1").Select
'Hide again columns AA and AB
cnOutput.Columns("AA:AB").Hidden = True
Next j
'END OF CODE FOR OWNER 1
'------------------------------------------------------------------------------------------------------------------------------
'Protect the original worksheet with password 1234
With cnOutput
.Protect Password:="1234", _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
AllowFormattingCells:=True, _
AllowFormattingColumns:=True, _
AllowFormattingRows:=True, _
AllowInsertingColumns:=False, _
AllowInsertingRows:=False, _
AllowDeletingColumns:=False, _
AllowDeletingRows:=False, _
AllowSorting:=True, _
AllowFiltering:=True, _
AllowUsingPivotTables:=True, _
UserInterfaceOnly:=True
End With
Application.ScreenUpdating = True
MsgBox "Workbooks have been created and data copied succesfully", vbExclamation
End SubI cannot attach the workbook which would have been more meaningful for you.
Any help will be appreciated
Thanks in advance
George
