Excel VBA Script to convert a diarised resource allocation xls into a normalised list
2329
£30(approx. $38)
- Posted:
- Proposals: 7
- Remote
- #1802891
- Archived
Excel | VBA | Macro | MS Access | MS Word | PowerPoint Program | .Net | C# | VB.Net
Bangalore
12280505066614494331889454188965319248171927621
Description
Experience Level: Intermediate
General information for the business: Managing resources for multiple clients at different rates
Kind of development: Customization of existing program
Description of requirements/functionality: i have an xls for resource management that allows me to see which employee is allocated to which client on which day.
there are 2 tabs. each tab represents a different technology stack, nad is formatted identically.
Each row has a single employee, each column is for a date, and each cell on that row has the name of the client they're allocated to for that day.
the script needs to
1. read the resource management xls, (RSC)
2. create a new tab in my target xls, (ANL)
3. for each row in the two tabs and for each employee, per day (i.e. cell) convert this into another xls with a single row per resource per day.
During this process the script needs to do a lookup, based on the date range, to find the appropriate rate and contract id for that client and resource and add that to the new tab.
The script is almost complete and working but the lookup with date range is beyond my skills.
This will take a decent developer less than an hour to complete.
The current script also takes a long time if ALL clients are selected, so it needs to run within 10secs for a single client and less than 1 min for all clients...on a decent laptop.
Extra notes: Function MYVLOOKUP(pValue As String, pWorkRng As Range, pIndex As Long)
'Update 20150310
Dim rng As Range
Dim xResult As String
xResult = ""
For Each rng In pWorkRng
If Trim(rng) = Trim(pValue) Then
xResult = xResult & " " & rng.Offset(0, pIndex - 1)
End If
Next
If Trim(xResult) = "" Then
xResult = "Nothing"
End If
MYVLOOKUP = Trim(xResult)
End Function
Sub SheetKiller()
Dim s As Worksheet, t As String
Dim i As Long, K As Long
K = Sheets.Count
For i = K To 1 Step -1
t = Sheets(i).Name
If t = "All_norm" Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
End If
Next i
End Sub
Sub Normalise()
'Flattens Diary Out.
Dim LastR As Long
Dim LastC As Long
Dim arr As Variant
Dim DestR As Long
Dim RowCount As Long
Dim ColCount As Long
Dim myArray(1 To 2) As String
Dim InWorksheet As String
Dim customerWorkbook As Workbook
Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim y As Workbook
Dim myTableArray As Range
Set y = ActiveWorkbook
With y.Worksheets("SOW")
Set myTableArray = .Range(.Cells(2, 1), .Cells(100, 3))
End With
myArray(1) = "BI"
myArray(2) = "AX"
Call SheetKiller
Worksheets.Add.Name = "All" + "_norm"
[a1:F1].Value = Array("Division", "Name", "Date", "Customer", "Project_Code", "Rate")
DestR = 1
' get the customer workbook
filter = "Text files (*.xlsx),*.xlsx"
caption = "Please Select an input file "
customerFilename = Application.GetOpenFilename(filter, , caption)
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
For i = 1 To UBound(myArray)
InWorksheet = myArray(i)
With customerWorkbook.Worksheets(InWorksheet)
LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
LastC = .Cells(.Columns.Count).End(xlToLeft).Column
arr = .Range(.[a2], .Cells(LastR, LastC)).Value
For RowCount = 3 To LastR - 1
For ColCount = 6 To LastC
' If arr(RowCount, ColCount) = "Customer" Then
If IsDate(arr(1, ColCount)) = True And arr(RowCount, ColCount) <> "" Then
Dim myLookupValue As String
Dim myRate As Variant
Dim myProject As Variant
' On Error Resume Next
DestR = DestR + 1
myLookupValue = Trim(arr(RowCount, 1))
myRate = Application.VLookup(myLookupValue, myTableArray, 2, False)
myProject = Application.VLookup(myLookupValue, myTableArray, 3, False)
y.Sheets("All_norm").Cells(DestR, 1) = InWorksheet
y.Sheets("All_norm").Cells(DestR, 2) = Trim(arr(RowCount, 1))
y.Sheets("All_norm").Cells(DestR, 3) = arr(1, ColCount)
y.Sheets("All_norm").Cells(DestR, 4) = arr(RowCount, ColCount)
If IsError(myProject) = False Then
y.Sheets("All_norm").Cells(DestR, 5) = myProject
Else
y.Sheets("All_norm").Cells(DestR, 5) = "0"
Kind of development: Customization of existing program
Description of requirements/functionality: i have an xls for resource management that allows me to see which employee is allocated to which client on which day.
there are 2 tabs. each tab represents a different technology stack, nad is formatted identically.
Each row has a single employee, each column is for a date, and each cell on that row has the name of the client they're allocated to for that day.
the script needs to
1. read the resource management xls, (RSC)
2. create a new tab in my target xls, (ANL)
3. for each row in the two tabs and for each employee, per day (i.e. cell) convert this into another xls with a single row per resource per day.
During this process the script needs to do a lookup, based on the date range, to find the appropriate rate and contract id for that client and resource and add that to the new tab.
The script is almost complete and working but the lookup with date range is beyond my skills.
This will take a decent developer less than an hour to complete.
The current script also takes a long time if ALL clients are selected, so it needs to run within 10secs for a single client and less than 1 min for all clients...on a decent laptop.
Extra notes: Function MYVLOOKUP(pValue As String, pWorkRng As Range, pIndex As Long)
'Update 20150310
Dim rng As Range
Dim xResult As String
xResult = ""
For Each rng In pWorkRng
If Trim(rng) = Trim(pValue) Then
xResult = xResult & " " & rng.Offset(0, pIndex - 1)
End If
Next
If Trim(xResult) = "" Then
xResult = "Nothing"
End If
MYVLOOKUP = Trim(xResult)
End Function
Sub SheetKiller()
Dim s As Worksheet, t As String
Dim i As Long, K As Long
K = Sheets.Count
For i = K To 1 Step -1
t = Sheets(i).Name
If t = "All_norm" Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
End If
Next i
End Sub
Sub Normalise()
'Flattens Diary Out.
Dim LastR As Long
Dim LastC As Long
Dim arr As Variant
Dim DestR As Long
Dim RowCount As Long
Dim ColCount As Long
Dim myArray(1 To 2) As String
Dim InWorksheet As String
Dim customerWorkbook As Workbook
Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim y As Workbook
Dim myTableArray As Range
Set y = ActiveWorkbook
With y.Worksheets("SOW")
Set myTableArray = .Range(.Cells(2, 1), .Cells(100, 3))
End With
myArray(1) = "BI"
myArray(2) = "AX"
Call SheetKiller
Worksheets.Add.Name = "All" + "_norm"
[a1:F1].Value = Array("Division", "Name", "Date", "Customer", "Project_Code", "Rate")
DestR = 1
' get the customer workbook
filter = "Text files (*.xlsx),*.xlsx"
caption = "Please Select an input file "
customerFilename = Application.GetOpenFilename(filter, , caption)
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
For i = 1 To UBound(myArray)
InWorksheet = myArray(i)
With customerWorkbook.Worksheets(InWorksheet)
LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
LastC = .Cells(.Columns.Count).End(xlToLeft).Column
arr = .Range(.[a2], .Cells(LastR, LastC)).Value
For RowCount = 3 To LastR - 1
For ColCount = 6 To LastC
' If arr(RowCount, ColCount) = "Customer" Then
If IsDate(arr(1, ColCount)) = True And arr(RowCount, ColCount) <> "" Then
Dim myLookupValue As String
Dim myRate As Variant
Dim myProject As Variant
' On Error Resume Next
DestR = DestR + 1
myLookupValue = Trim(arr(RowCount, 1))
myRate = Application.VLookup(myLookupValue, myTableArray, 2, False)
myProject = Application.VLookup(myLookupValue, myTableArray, 3, False)
y.Sheets("All_norm").Cells(DestR, 1) = InWorksheet
y.Sheets("All_norm").Cells(DestR, 2) = Trim(arr(RowCount, 1))
y.Sheets("All_norm").Cells(DestR, 3) = arr(1, ColCount)
y.Sheets("All_norm").Cells(DestR, 4) = arr(RowCount, ColCount)
If IsError(myProject) = False Then
y.Sheets("All_norm").Cells(DestR, 5) = myProject
Else
y.Sheets("All_norm").Cells(DestR, 5) = "0"
John C.
100% (1)Projects Completed
1
Freelancers worked with
1
Projects awarded
25%
Last project
20 Dec 2017
United Kingdom
New Proposal
Login to your account and send a proposal now to get this project.
Log inClarification Board Ask a Question
-
There are no clarification messages.
We collect cookies to enable the proper functioning and security of our website, and to enhance your experience. By clicking on 'Accept All Cookies', you consent to the use of these cookies. You can change your 'Cookies Settings' at any time. For more information, please read ourCookie Policy
Cookie Settings
Accept All Cookies