I have a project where I need to open all territory files associated with a district in a range of districts, looping through each district. All files for that district need to be opened in the periods (months) equal to and prior to an inputted month value. The files need to be opened one at a time with values from certain variant worksheets in that file copied and pasted into another master file. The structure of the files is Path\Year\District\Period\Territory.xlsx.
I am encountering errors with the following code which attempts to capture the month for the report and compare it to the Period variable. I am getting the Next without For error.
Sub DSMReports()
Sheets("START").Activate
Dim MM As Variant
Dim YYYY As Variant
MM = InputBox("Enter Month for reporting in MM format: 01-12")
YYYY = InputBox("Enter Year for reporting in YYYY format")
Range("C6").Value = MM
Range("C8").Value = YYYY
Dim DistrictDSM As Range
Dim DistrictsDSMList As Range
Set DistrictsDSMList = Start.Range("E11:E23")
Dim Path As String
Dim DistPeriodFile As String
Dim Total As Integer
Dim Period As Integer
For Each DistrictDSM In DistrictsDSMList.Cells
Total = 0
For Period = 1 To MM
Period = Total + 1
If Period < 10 Then Path = "\\corsrv027\Accounting\Monthend " & YYYY & "\DSM Files\" & DistrictDSM & "\P0" & Period
If Period >= 10 Then Path = "\\corsrv027\Accounting\Monthend " & YYYY & "\DSM Files\" & DistrictDSM & "\P" & Period
DistPeriodFile = Dir(Path & "\*.xlsx")
Do While DistPeriodFile <> ""
Workbooks.Open Filename:=Path & "\" & DistPeriodFile
'Do copying, pasting, and going through each worksheet one at a time here
DistPeriodFile = Dir
Next Period
Next DistrictDSM
Loop
End Sub
Fix the Next Without For error by moving the Loop of the Do While loop before the Next Period and Next DistrictDSM. Indentation visualizes and helps properly structure your loops, and would have highlighted your "interwoven" loop structure.
For Each DistrictDSM In DistrictsDSMList.Cells
' code
For Period = 1 To MM
' more code
Do While DistPeriodFile <> ""
' more code
Loop
Next Period
Next DistrictDSM
I have some macros that were working previously like:
Sub test()
'
' test Macro
'
Windows("_Macro_Duplicate Billing Templates.xltm").Activate
Src2 = Sheets("Parameters").Range("C12").Value
Workbooks.Open Filename:=Src2
End Sub
where I indicated "D:\Users\D801878\Int'l\Billing\2017_03\Billing Template_International_2017_03.xlsx" in cell C12
This was working in 2016 till now. Now I get the error that "D:\Users\D801878\Int'l\Billing\2017_03\Billing Template_International_2017_03.xlsx is not found."
Did anything change in terms of naming the filepath and filename?
I recommend to make like this:
I'm supposed the value 03 means the number of the month witch is march or mar, so:
Put in C12 the date mar.2017 and use the following code:
Dim y As Integer
Dim m As String
Dim ws As Worksheet
Dim link As String
Set ws = ThisWorkbook.Worksheets("Parameters")
y = Format(ws.Range("C12"), "yyyy")
m = Format(ws.Range("C12"), "mm")
link = "D:\Users\D801878\Int'l\Billing\" & y & "_" & m & "\Billing_Template_International_" & y & "_" & m & ".xlsx"
Workbooks.Open link
I am trying build a macro to give me the date and time production will end based on a value entered into cell A2. At present each unit takes 1 min 5 sec to produce. the shift will finish at 00:30 and restart at 05:30 so I would like it to take this into consideration.
Some examples
If the date/time is 14/03/2017 22:00 and I enter 55 into cell A2 I would expect a return of 14/03/2017 23:00 in cell E2.
If the date/time is 14/03/2017 22:00 and I entered 1 into cell A2 I would expect a return of 14/03/2017 22:01 in cell E2.
If the time is 14/03/2017 23:55 and I entered 55 into cell A2 I would expect a return of 15/03/2017 05:55
So at the moment I am using this code which works well within the shift but I cant get any further with it ie. going into the next days production.
Range("A2").Value * Range("C2").Value + Now()
A2 being the number of units and C2 being the process time 0,1,5
Many thanks for your help /advice
I'm not sure what the problem is. The maths are (units * time-per-unit) + start time. The brackets are for visual clrity only; mathematical precedence will ensure that the multiplication takes place before the addition.
With Worksheets("sheet1")
.Range("E2") = Now
.Range("F2") = .Range("E2").Value2 + (.Range("A2").Value2 * .Range("C2").Value2)
.Range("G2") = Application.Ceiling(.Range("F2").Value2, TimeSerial(0, 0, 1))
.Range("E2:G2").NumberFormat = "[Color10][$-en-US]dd-mmm-yyyy hh:mm;[Color3]#"
End With
FWIW, I've had better success using .Value2 instead of .Value as it is a raw numerical without additional date/time/currency information.
This took a little time but it turned out rather nice. Follow these instructions to test.
Create a standard code module in the workbook in which you want the action to occur. The name will be "Module1" by default. I suggest you change it to "Main" or some better, descriptive name. Paste the following enumerations at the top of your module, including the option statement.
Option Explicit
Enum Nws ' Worksheet navigation
NwsFirstDataRow = 2
NwsQty = 1 ' Columns (not necessarily contiguous):
NwsTime ' time to produce one unit
NwsStart ' date/time
NwsEnd ' date/time
End Enum
This enumeration serves to identify rows and columns in your worksheet. Note that columns are numbered (1=A, 2=B, 3=C etc.) Enumerations without a value assume the value of the previous one +1. So, NwsEnd = 4 = column D. You can set up the sheet according to the enum or adjust the enum values to match your sheet, but you must have a column for each of Quantity, Production time, Production Start time, and Production completion time. NwsFirstDataRow serves to prevent the macro from changing data you don't want changed - at least those in the caption row, here presumed to be row 1.
Now past the next enumeration below the above.
Enum Nsh ' Shift (use 24h format)
NshStart = 530 ' read as 05:30 (on current day)
NshEnd = 2430 ' read as 00:30 (on next day)
End Enum
This enum holds a code for your shift time. In the future, if your working hours change, you can modify the code's output simply by changing these numbers.
The next sub is doing most of the work.
Sub SetCompletion(Ws As Worksheet, R As Long)
' 20 Mar 2017
Dim Qty As Long
Dim ShiftQty As Long, DayQty As Long
Dim UnitTime As Double, StartTime As Double
Dim ComplDate As Double
Dim Days As Integer
With Rows(R)
Qty = .Cells(NwsQty).Value
UnitTime = .Cells(NwsTime).Value
StartTime = .Cells(NwsStart).Value
If Qty And (UnitTime > 0) And (StartTime > 0) Then
ComplDate = (UnitTime * Qty) + StartTime
ShiftQty = QtyTillShiftEnd(StartTime, UnitTime)
If ShiftQty < Qty Then
Qty = Qty - ShiftQty
DayQty = DailyProduction(UnitTime)
ComplDate = StartTime + 1 + Int(Qty / DayQty)
ComplDate = ComplDate + UnitTime * (Qty Mod DayQty)
End If
.Cells(NwsEnd).Value = ComplDate
End If
End With
End Sub
Its basic calculation method is to first calculate how many units can be produced from the start of production until the end of that day's shift. Then calculate the full days' production, and calculate the completion from the number of remaining units to be produced on the last day. No such calculation will be made while any of the 3 required components are missing (Qty, Time, StartTime). The following functions are helping in the calculation. Paste them at the bottom of the same "Main" code module.
Private Function QtyTillShiftEnd(ByVal StartTime As Double, _
ByVal UnitTime As Double) As Double
' 20 Mar 2017
Dim ProdTime As Double
ProdTime = (Int(StartTime) + NshToDays(NshEnd) - StartTime)
QtyTillShiftEnd = (ProdTime + 0.0001) / UnitTime
End Function
Calculates the quantity that can be produced from the start time until the end of the first production day's shift. The next function calculates a full day's production.
Private Function DailyProduction(UnitTime As Double) As Integer
' 19 Mar 2017
DailyProduction = Int((NshToDays(NshEnd) - NshToDays(NshStart) + 0.000001) / UnitTime)
End Function
When working with Double type numbers, required for time calculations, VB has difficulty calculating zero. The 0.000001 added to the result ensures that the calculation doesn't end up below zero when zero is required. The next function converts the encoded shift times from Enum Nsh into fractions of days which this program can work with.
Private Function NshToDays(TimeCode As Nsh) As Double
' 19 Mar 2017
Dim H As Double, M As Double
H = Int(TimeCode / 100)
M = TimeCode Mod 100
NshToDays = (1 / 24 * H) + (1 / 24 / 60 * M)
End Function
The next function corrects wrong entries in the StartTime column NwsStart.
Function AdjustedStartTime(ByVal StartTime As Double) As Double
' 19 Mar 2017
' return new StartTime or 0
Dim Fun As Double
Dim StartDate As Long
Dim ShiftStart As Double, ShiftEnd As Double
ShiftStart = NshToDays(NshStart)
ShiftEnd = NshToDays(NshEnd)
StartDate = Int(StartTime)
StartTime = StartTime - StartDate
Fun = StartTime
If ShiftEnd > 1 Then
If StartTime < (ShiftStart - Int(ShiftStart)) Then
If StartTime > (ShiftEnd - Int(ShiftEnd)) Then Fun = ShiftStart
End If
Else
If (StartTime - Int(StartTime)) < ShiftStart Then
Fun = ShiftStart
Else
If StartTime > ShiftEnd Then Fun = ShiftStart + 1
End If
End If
AdjustedStartTime = Fun + StartDate
End Function
This function's action is to make sure that no one enters a time like 4:00 am. If someone does the entry will be changed to 05:30 because that's when the shift starts.
The last procedure in this code sheet formats cells.
Sub FormatCells(Row As Range)
' 19 Mar 2017
Dim Fmt As Variant, Clm As Variant
Dim i As Integer
' match for number formats in 'Fmt' to the column numbers in 'Clm'
Clm = Array(NwsQty, NwsTime, NwsStart, NwsEnd)
Fmt = Array("#,##0", "hh:mm:ss", "dd mmm hh:mm", "dd mmm hh:mm")
For i = 0 To UBound(Clm)
Row.Cells(Clm(i)).NumberFormat = Fmt(i)
Next i
End Sub
This sub will be called whenever a production quantity is entered. You can adjust the cell formats here. This goes especially for the date formats which I may not have done to your liking.
Now, still in the VBE window, please find the code sheet for the worksheet on which you have the columns first above enumerated. It might be listed in the Project window as Sheet1(Sheet1) or similar. It is important that you identify the correct sheet and paste the following procedure there.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' 20 Mar 2017
Dim Entry As Variant
With Target
' no action when more than one cell is modified at once
If .Cells.Count = 1 And .Row >= NwsFirstDataRow Then
Application.EnableEvents = False
Entry = .Value
Select Case .Column
Case NwsQty
If Val(Entry) < 1 Then
If Len(Entry) > 0 Then
MsgBox "Please enter a number representing" & vbCr & _
"the quantity to be produced.", vbExclamation, _
"Invalid entry"
.Select
End If
Else
FormatCells Rows(.Row)
SetCompletion ActiveSheet, .Row
End If
Case NwsTime
If Val(Entry) Then
SetCompletion ActiveSheet, .Row
Else
If Len(Entry) > 0 Then
MsgBox "The production time must be entered" & vbCr & _
"in the format h:m:s", vbExclamation, _
"Invalid entry"
.Select
End If
End If
Case NwsStart
If Val(Entry) Then
If (Val(Entry) < 1) Then .Value = Entry + Date
Entry = AdjustedStartTime(.Value)
If .Value <> Entry Then
MsgBox "On " & Format(Entry, "mmm d") & " production doesn't " & _
"start until " & Format(Entry, "h:mm") & "." & vbCr & _
"Your entry was adjusted accordingly.", _
vbInformation, "Corrected time entry"
.Value = Entry
End If
SetCompletion ActiveSheet, .Row
Else
MsgBox "The production start must be entered as a Time" & vbCr & _
"or Dtae/Time value in the format [d/m/yy] HH:mm", _
vbExclamation, "Invalid entry"
.Select
End If
Case NwsEnd
MsgBox "Recalculate with a new production start?" & vbCr & _
"The completion date is the result of a calculation." & vbCr & _
"To change it, modify the unit production time.", _
vbInformation, "Invalid action"
Application.Undo
End Select
Application.EnableEvents = True
End If
End With
End Sub
You can get a fair idea of what this procedure does by reading the various error messages it can spit out. You can modify these texts. Note that you can enter the start time as a time or Date/Time. If you enter time only the macro will add the current date automatically. In the absence of errors this macro will call the sub SetCompletion which will write the completion date to the sheet if all criteria for its calculation are present.
Note that there is no protection of your data after change of Enum Nsh. To avoid overwriting existing completion dates which were calculated with previously correct shift times, set the enumeration NwsFirstDataRow to exclude rows you wish to protect in this way.
All components have been tested, but the project as a whole is rather complex and you would do well to watch the results in real life. You may have noticed that I have structured the code in such a way that faults can easily be attributed to specific functions which may then have to be improved without putting everything into question.
The problem is with the date format, more specifically, the input date format in the start time column. The macro will only calculate if a start time is given. So, when the start time is given but not recognised as such no calculation takes place.
I programmed for day/month/year and you are using the American system. Please replace the existing procedure of the same name with this one.
Sub FormatCells(Row As Range)
' 25 Mar 2017
Dim Fmt As Variant, Clm As Variant
Dim i As Integer
' match for number formats in 'Fmt' to the column numbers in 'Clm'
Clm = Array(NwsQty, NwsTime, NwsStart, NwsEnd)
Fmt = Array("#,##0", "hh:mm:ss", "mmm dd hh:mm", "mmm dd hh:mm")
For i = 0 To UBound(Clm)
Row.Cells(Clm(i)).NumberFormat = Fmt(i)
Next i
End Sub
Modifications have also been made to the event procedure which will now recognise dates entered in your format. Please remember that you are supposed to be able to enter the start time as 7:30 and have the cell display Mar 25 07:30. Try this. also try entering "Mar 20 7:30", "3/20/17 7:30", "3/20 7:30", and then "3/20/17 14:00" and perhaps "3/20/17 2:00 PM". If it doesn't work that would be indication of bigger wrongs behind the scenes.
Private Sub Worksheet_Change(ByVal Target As Range)
' 25 Mar 2017
Dim Entry As Variant
With Target
' no action when more than one cell is modified at once
If .Cells.Count = 1 And .Row >= NwsFirstDataRow Then
Application.EnableEvents = False
Entry = .Value
Select Case .Column
Case NwsQty
If Val(Entry) < 1 Then
If Len(Entry) > 0 Then
MsgBox "Please enter a number representing" & vbCr & _
"the quantity to be produced.", vbExclamation, _
"Invalid entry"
.Select
End If
Else
FormatCells Rows(.Row)
SetCompletion ActiveSheet, .Row
End If
Case NwsTime
If Val(Entry) Then
SetCompletion ActiveSheet, .Row
Else
If Len(Entry) > 0 Then
MsgBox "The production time must be entered" & vbCr & _
"in the format h:m:s", vbExclamation, _
"Invalid entry"
.Select
End If
End If
Case NwsStart
If IsDate(Entry) Then
If (CDbl(Entry) < 1) Then .Value = Entry + Date
Entry = AdjustedStartTime(.Value)
If .Value <> Entry Then
MsgBox "On " & Format(Entry, "mmm d") & " production doesn't " & _
"start until " & Format(Entry, "h:mm") & "." & vbCr & _
"Your entry was adjusted accordingly.", _
vbInformation, "Corrected time entry"
.Value = Entry
End If
SetCompletion ActiveSheet, .Row
Else
MsgBox "The production start must be entered as a Time" & vbCr & _
"or Date/Time value in the format [m/d/yy] HH:mm", _
vbExclamation, "Invalid entry"
.Select
End If
Case NwsEnd
MsgBox "Recalculate with a new production start?" & vbCr & _
"The completion date is the result of a calculation." & vbCr & _
"To change it, modify the unit production time.", _
vbInformation, "Invalid action"
Application.Undo
End Select
Application.EnableEvents = True
End If
End With
End Sub
Last but not least, I discovered an error in the calculation of the completion time affecting production time ending not on the same day. I corrected it. Please exchange the functions.
Sub SetCompletion(ws As Worksheet, R As Long)
' 25 Mar 2017
Dim Qty As Long
Dim ShiftQty As Long, DayQty As Long
Dim UnitTime As Double, StartTime As Double
Dim ComplDate As Double
Dim Days As Integer
With Rows(R)
Qty = .Cells(NwsQty).Value
UnitTime = .Cells(NwsTime).Value
StartTime = .Cells(NwsStart).Value
If Qty And (UnitTime > 0) And (StartTime > 0) Then
ComplDate = (UnitTime * Qty) + StartTime
ShiftQty = QtyTillShiftEnd(StartTime, UnitTime)
If ShiftQty < Qty Then
Qty = Qty - ShiftQty
DayQty = DailyProduction(UnitTime)
ComplDate = Int(StartTime) + 1 + NshToDays(NshStart) + Int(Qty / DayQty)
ComplDate = ComplDate + UnitTime * (Qty Mod DayQty)
End If
.Cells(NwsEnd).Value = ComplDate
End If
End With
End Sub
Actually, this procedure should be further amended to recognise weekends, but I hope that your production wouldn't stop on Sundays :-)
I shall appreciate your bearing with me in case you still face a problem with the dates. I could change the default settings on my PC for better testing, but so far I have avoided doing so. :-)
The text in your event procedure should be changed in the light of changes you want to make to the code. Please replace as follows:-
MsgBox "You entered a time during which production rests." & vbCr & _
"The next shift after that will start on " & _
Format(Entry, "dddd,") & vbCr & _
Format(Entry, "mmmm d,") & " at " & _
Format(Entry, "h:mm") & "." & vbCr & _
"Your entry was adjusted accordingly.", _
vbInformation, "Corrected time entry"
' MsgBox "On " & Format(Entry, "mmm d") & " production doesn't " & _
' "start until " & Format(Entry, "h:mm") & "." & vbCr & _
' "Your entry was adjusted accordingly.", _
' vbInformation, "Corrected time entry"
Meaning, look for the lines of code with apostrophes at their beginning above and replace them with the liens that don't have an apostrophe.
I suggest you post a link to this thread in the new thread you just started.
I am stuck on a transfer of data in to a summary sheet. I have 2 sheets and want to summarize it in to a third sheet.
Sheet A
A B C D
1 Apple Orange Peach
2 Period Apple_Price Orange_price peach_price
3 1 5 5 3
4 2 6 4 9
5 3 7 7
Sheet B
A B C D
1 Apple Orange Peach
2 Period Apple_weight Orange_Weight peach_Weight
3 1 2.1 2.5 3.1
4 2 2.1 1.1 2.1
5 3 3.1 2.5
Summary sheet or sheet c (expected)
A B C D
1 Period Price Weight
2 Apple 1 5 2.1
3 2 6 2.1
4 3 7 3.1
5 Orange 1 5 2.5
6 2 4 1.1
7 Peach 1 3 3.1
8 2 9 2.1
9 3 7 2.5
The code I have started writing is somewhat like
For Each Name In Range("B1:D1")
' To copy each name in to first column of summary
Name.Cells.value.copy Worksheets("Summary").Offset(2,0)
' Now to copy a column from each sheet in front of corresponding name
Worksheets("SheetA").Range(Name & lastrow).Copy
Worksheets("summary").Range("a65536").End(xlUP).Offset(2,1)
'Now copy Periods and prices
Worksheets("SheetA").Range(Name & lastrow).Copy
Worksheets("summary").Range("a65536").End(xlUP).Offset(2,2)
'Now copy weights
Worksheets("SheetB").Range(Name & lastrow).Copy
Worksheets("summary").Range("a65536").End(xlUP).Offset(2,3)
Next
Unfortunately I am not able to get this work. There's some problem with offset I guess.
First let us look at your existing code.
For Each Name In Range("B1:D1")
This assumes three fruit. When you add a fourth, you will have to update this code and again when you add a fifth. Does the person who decides which fruit are of interest, maintain the macro? If not, every time they add a fruit, they will have to request an update to the macro.
Deciding what possible future changes to allow for is a balance:
It is almost no effort to allow for extra fruit or extra periods and in most situations this is a very likely change so I normally allow for it.
Currently you have price and weight as interesting properties. Allowing for new properties could be tricky; I would not normally bother.
Are the fruit in the same sequence? Are the periods in the same sequence? Allowing for these changes is more bother than allowing for extra fruit or periods so should I allow for them? In an earlier life, I was responsible for a lot of similar tasks. Worksheets formats were often changed for no reason I could understand. If I simply assumed the worksheets were the format I expected, I could create realistic but wrong summaries and the error might not be recognised for some time. At the very least, I always performed checks for worksheets being in the format I expected.
I am not asking you to agree with my assessment of what changes to prepare for since I know nothing about your application. I am asking you to think about the issue. A change you have not checked for could lead to a corrupt summary or a crashed macro. How important is this? A change you have checked for but do not handle means the macro cannot be run until you update it. How important is this?
Worksheets("summary").Range("a65536").End(xlUP).Offset(2,1)
Prior to Excel 2007, a worksheet had 65536 rows so cell A65536 was the bottom of column A. Anyone who has coded since 2007 would have suggested Cells(Rows.Count, 1) instead of Range("a65536")because it specifies the bottom of column A for the current version of Excel whatever it is.
I do not like Offset because you have to perform mental arithmetic to determine which cell is being addressed. If the number of periods is not always exactly three, you will have to perform arithmetic on the offset row. That is: Offset(2, 1) will have to be replaced by something like Offset(2+Period-1, 1). In addition you have started at the bottom of column A, moved up to the first cell in the column with a value before performing the offset.
If your code is to be performed millions of times per day, shaving a millisecond off the run time might be appropriate but is it appropriate here? How long did it take you to write this code (which does not work anyway) and how long will it take a future maintainer of your code to understand what you are doing? My advice is to make code simple and easy to write unless there is some overwhelming reason for it to be complex and difficult to write.
My code included little tricks for saving time. These are all easy to implement and can become automatic. If it takes you 10 or 20 seconds to type a statement that saves the user a noticeable fraction of a second, the company can get a return on its investment (Your coding time < User's waiting time) within a few months. Also, some of these tricks make future maintenance easier. Always make life easier for the person who has to update this macro in 6 or 12 months because that person might be you.
Please do not use name like “SheetA” or “SheetB”. Names like “Price” and “Weight” immediately tell you the worksheet’s purpose. Meaningful names make like so much easier.
I think that is enough criticism.
Work through this code carefully. There are lots of comments explaining what I am attempting but few comments explaining what each statement does so you will have to look those up if you don’t know and cannot guess. Use F8 to step through the macro statement by statement. Do you understand what each statement does and why I wanted that done? Come back with questions if necessary but the more you can work out for yourself the faster you will develop your own skills.
Option Explicit
' Constants make maintenance so much easier:
' * You code is full of meaningful names rather than numbers whos purpose
' must be looked up.
' * If columns are rearranged or an extra heading line added to one of the
' worksheets, one change here and the problem is fixed.
Const ColPWPeriod As Long = 1
Const ColPWDataFirst As Long = 2
Const ColSummaryFruit As Long = 1
Const ColSummaryPeriod As Long = 2
Const ColSummaryPrice As Long = 3
Const ColSummaryWeight As Long = 4
Const ColSummaryLast As Long = 4
Const RowPWFruit As Long = 1
Const RowPWDataFirst As Long = 3
Sub CombineABIntoS()
Dim ColPriceLast As Long
Dim ColPWCrnt As Long
Dim ColWeightLast As Long
Dim FruitCrnt As String
Dim RowPriceLast As Long
Dim RowPWCrnt As Long
Dim RowSummaryCrnt As Long
Dim RowWeightLast As Long
Dim WshtPrice As Worksheet
Dim WshtWeight As Worksheet
Dim WshtSummary As Worksheet
' Updating the screen for each change can be very time consuming.
Application.ScreenUpdating = False
' * It takes the interpreter a noticable fraction of a second to process
' Worksheets("Xxxxx") because it has to look "Xxxxx" up in its collection
' of worksheet names. These cause these look ups to be performed once and
' the result stored. With all the switching between worksheets this can
' reduce duration noticably.
' * If the names of the worksheets change, only these statements will need
' amendment to fully update the macro.
' * These are not your names. If you do not accept my advice, change to
' your worksheet names
Set WshtPrice = Worksheets("Price")
Set WshtWeight = Worksheets("Weight")
Set WshtSummary = Worksheets("Summary")
' For price worksheet, find last row with a period and last column with a fruit
With WshtPrice
ColPriceLast = .Cells(1, Columns.Count).End(xlToLeft).Column
RowPriceLast = .Cells(Rows.Count, ColPWPeriod).End(xlUp).Row
End With
' For weight worksheet, find last row with a period and last column with a fruit
With WshtWeight
ColWeightLast = .Cells(1, Columns.Count).End(xlToLeft).Column
RowWeightLast = .Cells(Rows.Count, ColPWPeriod).End(xlUp).Row
End With
' Check worksheets match.
' Check same number of fruits
If ColPriceLast <> ColWeightLast Then
Call MsgBox("Worksheet " & WshtPrice.Name & " has " & _
ColPriceLast - ColPWDataFirst + 1 & _
" fruit while worksheet " & WshtWeight.Name & " has " & _
ColWeightLast - ColPWDataFirst + 1 & _
". Sorry I cannot handle this situation", _
vbOKOnly, "Combine Price and Weight worksheets")
Exit Sub
End If
' Check same number of periods
If RowPriceLast <> RowWeightLast Then
Call MsgBox("Worksheet " & WshtPrice.Name & " has " & _
RowPriceLast - RowPWDataFirst + 1 & _
" periods while worksheet " & WshtWeight.Name & " has " & _
RowWeightLast - RowPWDataFirst + 1 & _
". Sorry I cannot handle this situation", vbOKOnly, _
"Combine Price and Weight worksheets")
Exit Sub
End If
' Check same fruits in same sequence.
' Note: have already checked ColPriceLast = ColWeightLast
For ColPWCrnt = ColPWDataFirst To ColPriceLast
If WshtPrice.Cells(RowPWFruit, ColPWCrnt).Value <> _
WshtWeight.Cells(RowPWFruit, ColPWCrnt).Value Then
Call MsgBox("Cell " & ColNumToCode(ColPWCrnt) & RowPWFruit & _
" of worksheet " & WshtPrice.Name & " = """ & _
WshtPrice.Cells(RowPWFruit, ColPWCrnt).Value & _
""" while the same cell in worksheet " & _
WshtWeight.Name & " = """ & _
WshtWeight.Cells(RowPWFruit, ColPWCrnt).Value & _
""". Sorry I cannot handle this situation", vbOKOnly, _
"Combine Price and Weight worksheets")
Exit Sub
End If
Next
' Check same periods in same sequence.
' Note: have already checked RowPriceLast = RowWeightLast
For RowPWCrnt = RowPWDataFirst To RowPriceLast
If WshtPrice.Cells(RowPWCrnt, ColPWPeriod).Value <> _
WshtWeight.Cells(RowPWCrnt, ColPWPeriod).Value Then
Call MsgBox("Cell " & ColNumToCode(ColPWPeriod) & RowPWCrnt & _
" of worksheet " & WshtPrice.Name & " = """ & _
WshtPrice.Cells(RowPWCrnt, ColPWPeriod).Value & _
""" while the same cell in worksheet " & _
WshtWeight.Name & " = """ & _
WshtWeight.Cells(RowPWCrnt, ColPWPeriod).Value & _
""". Sorry I cannot handle this situation", vbOKOnly, _
"Combine Price and Weight worksheets")
Exit Sub
End If
Next
' Formats of two worksheets match
' For summary worksheet, clear existing contents, create header row
' and initialise row counter
With WshtSummary
.Cells.EntireRow.Delete ' Clear any existing contents
.Cells(1, ColSummaryFruit).Value = "Fruit"
.Cells(1, ColSummaryPeriod).Value = "Period"
.Cells(1, ColSummaryPrice).Value = "Price"
.Cells(1, ColSummaryWeight).Value = "Weight"
.Range(.Cells(1, 1), .Cells(1, ColSummaryLast)).Font.Bold = True
RowSummaryCrnt = 2
End With
For ColPWCrnt = ColPWDataFirst To ColPriceLast
' Can copy across fruit from either worksheet since checked to match
WshtSummary.Cells(RowSummaryCrnt, ColSummaryFruit).Value = _
WshtPrice.Cells(RowPWFruit, ColPWCrnt).Value
For RowPWCrnt = RowPWDataFirst To RowPriceLast
If WshtPrice.Cells(RowPWCrnt, ColPWCrnt).Value <> "" Or _
WshtWeight.Cells(RowPWCrnt, ColPWCrnt).Value <> "" Then
' There is either a price or a weight or both for this period and fruit
' Can copy across period from either worksheet since checked to match
WshtSummary.Cells(RowSummaryCrnt, ColSummaryPeriod).Value = _
WshtPrice.Cells(RowPWCrnt, ColPWPeriod).Value
' Copy across price and weight
WshtSummary.Cells(RowSummaryCrnt, ColSummaryPrice).Value = _
WshtPrice.Cells(RowPWCrnt, ColPWCrnt).Value
WshtSummary.Cells(RowSummaryCrnt, ColSummaryWeight).Value = _
WshtWeight.Cells(RowPWCrnt, ColPWCrnt).Value
' Step summart row ready fro next period or fruit
RowSummaryCrnt = RowSummaryCrnt + 1
End If
Next RowPWCrnt
Next ColPWCrnt
End Sub
Function ColNumToCode(ByVal ColNum As Long) As String
Dim Code As String
Dim PartNum As Long
' Last updated 3 Feb 12. Adapted to handle three character codes.
If ColNum = 0 Then
ColNumToCode = "0"
Else
Code = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
Code = Chr(65 + PartNum) & Code
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
ColNumToCode = Code
End Function
I have VBA code which converts a given specific date format into a normal Date. Is there a way in which I can replace the entire column into my new date format may be by a button click or just using a function.
The code I have is:
Function CONVDATE(myDate) As Date
Dim arr
arr = Split(myDate)
CONVDATE = arr(1) & " " & arr(2) & " " & arr(5) & " " & arr(3)
End Function
Immediately to the right of your data enter:
=TEXT(LEFT(A1,11)&RIGHT(A1,4),"ddd mm dd yyyy")
and double-click the fill handle. Then select, Copy and Paste Special Values over the top.
If you want a VBA solution, and you are happy with your CONVDATE function, you can use something like the following to convert an entire column:
===================================
Option Explicit
Sub CONVALLDATES()
Dim RNG As Range, C As Range
'Next line may change depending on how your range to convert is set up
Set RNG = Range("A1", Cells(Rows.Count, "A").End(xlUp))
'Uncomment next line when debugged.
'application.ScreenUpdating = False
For Each C In RNG
With C
.Value = CONVDATE(C)
'.numberformat = whatever format you want it displayed
End With
Next C
Application.ScreenUpdating = True
End Sub
'---------------------------------------------
Function CONVDATE(myDate) As Date
Dim arr
arr = Split(myDate)
CONVDATE = arr(1) & " " & arr(2) & " " & arr(5) & " " & arr(3)
End Function
====================================
You should add some error checking to ensure the string you are trying to convert is, indeed, in the specific format.