Formula values using vba as per the data

Chefsohail

Board Regular
Joined
Oct 3, 2020
Messages
77
Office Version
  1. 365
Platform
  1. Windows
Hi Team, (@mumps @Tupe77 )

Need your expertise in here.

I have a workbook here which has 3 sheets.

1. first sheet named DS tracker has all the formulae i need in the cells.
2. 2nd sheet is the data sheet where i will add the data.
3. 3rd sheet is the lookup sheet where i will add data as required.

Here I will add a button in the Data Sheet, so that the team member can add the required data and then run the macro.
1. The macro should copy and paste all the values of the formulae in DS tracker sheet as per the data available in Data Sheet. For Row I and Row K, I want the formulae itself to appear and not the value as the users will need it whilst working.

2. The macro should -
a) open a new workbook.
b) copy the DS Tracker sheet from the macro workbook and paste the entire worksheet 'DS tracker' in the new workbook.
c) Create a new folder with todays date .. (If the folder is already created then continue saving the file in it)
d) Save this new workbook as 'DS_Tracker_Today's Date' as a .xlsx in the folder created above and keep it activated. (If a file is already saved with a name then add a continue saving it without overrite and give it a new name 'DS_Tracker_Today's Date (2)' or 'DS_Tracker_Today's Date (3)' or 'DS_Tracker_Today's Date (4)' as the case may be.
e) it should now close the above macro workbook without saving it.

Hope that helps.

Please let me know if you need any other information.
 
Last edited:

Chefsohail

Board Regular
Joined
Oct 3, 2020
Messages
77
Office Version
  1. 365
Platform
  1. Windows
or should i be using something like this -

VBA Code:
Columns("A:A").Select
    Selection.Copy
    Selection.End(xlUp).Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.

Chefsohail

Board Regular
Joined
Oct 3, 2020
Messages
77
Office Version
  1. 365
Platform
  1. Windows
Hey I checked the Macro 2 and that works fine.. I made a few modifications.

VBA Code:
Sub TS_Create_New_Workbook()

On Error GoTo ErrHand
Application.Calculation = xlAutomatic: Application.ScreenUpdating = False: Application.DisplayAlerts = False

Dim wb As Workbook, wbNew As Workbook
Set wb = ThisWorkbook: Set wbNew = Workbooks.Add

Dim PathBase As String, PathDate As String, BaseFileName As String, FreeFileName As String, FormDate As String
Dim i As Integer

' This reverse Date format for file system sorting purpose
FormDate = Format(Date, Format:="mmddyyyy")

' Variables for path and file names
PathBase = "H:\My Documents\Desktop\" ' Create this folder "C:\workbooks\" or change "C:\workbooks\" to exist folder
PathDate = FormDate & "\"
BaseFileName = "DS_Tracker_" & FormDate

' Check Date folder exist "C:\workbooks\" MUST CREATE MANUALLY!!!!!!
    If Dir(PathBase & PathDate, vbDirectory) = vbNullString Then
        VBA.FileSystem.MkDir (PathBase & PathDate)
    Else
        'MsgBox "Folder exists."
    End If

'Find non used FileName
For i = 1 To 50
    'check for existence of proposed filename
    If Dir(PathBase & PathDate & BaseFileName & "_(" & Format(i, "00") & ")" & ".xlsx") = vbNullString Then
        FreeFileName = BaseFileName & "_(" & Format(i, "00") & ")" & ".xlsx"
        Exit For
    End If
Next i

'Copy Sheet and remove default sheet
wb.Sheets("DS Tracker").Copy Before:=wbNew.Sheets(1)
wbNew.Sheets(2).Delete

'Save New Workbook
wbNew.SaveAs Filename:=PathBase & PathDate & FreeFileName
wbNew.Activate

' Closes the workbook from which the macro was run. This has been commented out, for testing.
Application.Wait (Now + TimeValue("0:00:3"))
wb.Close SaveChanges:=False

ErrHand:
Application.Calculation = xlAutomatic: Application.ScreenUpdating = True: Application.DisplayAlerts = True
If Err.Number <> 0 Then MsgBox "Something went badly wrong!" & vbCrLf & "VBA-code is ended!" & vbCrLf & vbCrLf & "Error number: " & Err.Number & " " & Err.Description: End
End Sub
 

Chefsohail

Board Regular
Joined
Oct 3, 2020
Messages
77
Office Version
  1. 365
Platform
  1. Windows
@Fluff ..Thanx for the reply.. I am not to confident how to fit in your suggestion in the below macro code. Please if you may help.

VBA Code:
Sub TS_Copy_Columns()
On Error GoTo ErrHand
Application.Calculation = xlManual: Application.ScreenUpdating = False: Application.DisplayAlerts = False

Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsDS As Worksheet, wsData As Worksheet: Set wsDS = wb.Worksheets("DS Tracker"): Set wsData = wb.Worksheets("Data")

' Copy columns
wsData.Range(wsData.UsedRange.Columns("A").Address).Copy wsDS.Columns("A")
wsData.Range(wsData.UsedRange.Columns("B").Address).Copy wsDS.Columns("C")
wsData.Range(wsData.UsedRange.Columns("C").Address).Copy wsDS.Columns("G")
wsData.Range(wsData.UsedRange.Columns("D").Address).Copy wsDS.Columns("H")
wsData.Range(wsData.UsedRange.Columns("E").Address).Copy wsDS.Columns("J")
wsData.Range(wsData.UsedRange.Columns("F").Address).Copy wsDS.Columns("L")
wsData.Range(wsData.UsedRange.Columns("G").Address).Copy wsDS.Columns("M")
wsData.Range(wsData.UsedRange.Columns("H").Address).Copy wsDS.Columns("N")
wsData.Range(wsData.UsedRange.Columns("I").Address).Copy wsDS.Columns("Q")
wsDS.Range("Q2:Q" & wsDS.UsedRange.Rows.Count).FillDown

' Filldown formulas
wsDS.Range("B2").Formula = "=LEFT(A2,8)": wsDS.Range("B2:B" & wsDS.UsedRange.Rows.Count).FillDown
wsDS.Range("D2").Formula = "=RIGHT(C2,5)": wsDS.Range("D2:D" & wsDS.UsedRange.Rows.Count).FillDown
wsDS.Range("E2").Formula = "=VLOOKUP(D2,'UOM Comm'!D:R,2,0)": wsDS.Range("E2:E" & wsDS.UsedRange.Rows.Count).FillDown
wsDS.Range("F2").Formula = "=VLOOKUP(D2,'UOM Comm'!D:R,7,0)": wsDS.Range("F2:F" & wsDS.UsedRange.Rows.Count).FillDown
wsDS.Range("i2").Formula = "=LEN(H2)": wsDS.Range("i2:i" & wsDS.UsedRange.Rows.Count).FillDown
wsDS.Range("k2").Formula = "=LEN(J2)": wsDS.Range("k2:k" & wsDS.UsedRange.Rows.Count).FillDown
wsDS.Range("P2").Value = Format(Date, Format:="mm/dd/yy"): wsDS.Range("P2:P" & wsDS.UsedRange.Rows.Count).FillDown
wsDS.Range("R2").Formula = "=IF(M2="""",""Failure"", IF(LEFT(J2,1)=CHAR(41),""Na"",""Auto Approve""))": wsDS.Range("R2:R" & wsDS.UsedRange.Rows.Count).FillDown
wsDS.Range("O2").Value = "Description New Task": wsDS.Range("O2:O" & wsDS.UsedRange.Rows.Count).FillDown


ErrHand:
Application.Calculation = xlAutomatic: Application.ScreenUpdating = True: Application.DisplayAlerts = True
If Err.Number <> 0 Then MsgBox "Something went badly wrong!" & vbCrLf & "VBA-code is ended!" & vbCrLf & vbCrLf & "Error number: " & Err.Number & " " & Err.Description: End
End Sub

I want the following to stay as formulae and not change..

wsDS.Range("i2").Formula = "=LEN(H2)": wsDS.Range("i2:i" & wsDS.UsedRange.Rows.Count).FillDown
wsDS.Range("k2").Formula = "=LEN(J2)": wsDS.Range("k2:k" & wsDS.UsedRange.Rows.Count).FillDown

Just the others to paste Values and number format.
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,129,594
Messages
5,637,299
Members
416,963
Latest member
zazama

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top