I am having an issue running my code through, because the Range.Value is different than the Range.NumberFormat. For example, my value is a date and time and I would like to test for the day of the week. I was able to get the number format to be Sun-Sat, however, I am unsure how to test for it with CountIf.
Dim rep as Worksheet
Dim day As Range
Dim time As Range
Dim wf As WorksheetFunction
Set rep = Worksheets("Report")
Set day = rep.Range("H1", rep.Range("H1").End(xlDown))
Set time = rep.Range("I1", rep.Range("I1").End(xlDown))
Set wf = WorksheetFunction
With rep
.Columns("H").NumberFormat = "dddd"
.Columns("I").NumberFormat = "AM/PM"
.Range("K1") = "Monday"
.Range("K2") = "Tuesday"
.Range("K3") = "Wednesday"
.Range("K4") = "Thursday"
.Range("K5") = "Friday"
.Range("K6") = "Saturday"
.Range("K7") = "Sunday"
.Range("M1") = "AM"
.Range("M2") = "PM"
.Range("L1") = wf.CountIf(day, "Monday")
.Range("L2") = wf.CountIf(day, "Tuesday")
.Range("L3") = wf.CountIf(day, "Wednesday")
.Range("L4") = wf.CountIf(day, "Thursday")
.Range("L5") = wf.CountIf(day, "Friday")
.Range("L6") = wf.CountIf(day, "Saturday")
.Range("L7") = wf.CountIf(day, "Sunday")
.Range("N1") = wf.CountIf(time, "AM")
.Range("N2") = wf.CountIf(time, "PM")
End With
This is what I have so far, but it only outputs 0 for the solution to the countif. Thanks in advance.
Here's another way to do the counts.
Note I did most of the "work" in VBA arrays as this is much faster than repeatedly accessing the worksheet:
EDIT: To include counting the number of entries in column H with AM or PM times
Option Explicit
Sub foo()
Dim rep As Worksheet
Dim rDts As Range
Dim vDts As Variant
Dim vCnts As Variant 'for the weekday count
Dim vAP As Variant 'for the AM PM count
Dim I As Long, J As Long
Set rep = Worksheets("sheet1")
'read dates into array -- faster processing
With rep
vDts = .Range(.Cells(1, 8), .Cells(.Rows.Count, 8).End(xlUp))
End With
'Results array
ReDim vCnts(1 To 7, 1 To 2)
vCnts(1, 1) = "Sunday"
vCnts(2, 1) = "Monday"
vCnts(3, 1) = "Tuesday"
vCnts(4, 1) = "Wednesday"
vCnts(5, 1) = "Thursday"
vCnts(6, 1) = "Friday"
vCnts(7, 1) = "Saturday"
ReDim vAP(1 To 2, 1 To 2)
vAP(1, 1) = "AM"
vAP(2, 1) = "PM"
'Do the counts
For I = 1 To UBound(vDts, 1)
J = Weekday(vDts(I, 1))
vCnts(J, 2) = vCnts(J, 2) + 1
'Check for AM or PM
If Hour(vDts(I, 1)) < 12 Then
vAP(1, 2) = vAP(1, 2) + 1
Else
vAP(2, 2) = vAP(2, 2) + 1
End If
Next I
'output the results
rep.Range("K1:L7").Value = vCnts
rep.Range("M1:N2").Value = vAP
End Sub
Related
I have the following code created by #ScottCraner which populates cells Q8:Q12 with the dates of each friday this month.
Sub myFri()
Dim OArr(1 To 5, 1 To 1) As Variant
Dim k As Long
k = 1
Dim i As Long
For i = DateSerial(Year(Date), Month(Date), 1) To DateSerial(Year(Date), Month(Date) + 1, 0)
If Weekday(i, vbSunday) = 7 Then
OArr(k, 1) = i
k = k + 1
End If
Next i
If k = 5 Then OArr(k, 1) = "-"
Worksheets("Sheet1").Range("Q8:Q12").Value = OArr
Worksheets("Sheet1").Range("Q8:Q12").NumberFormat = "mm/dd/yyyy"
End Sub
I have adjusted this to try and set the range to different sections of the sheet.
Ive done this with a Union range as follows:
Private Sub DateRangePayer1()
Dim rng1, rng2, rng3, rng4, UnionRange As Range
Set rng1 = Range("Q8:Q12")
Set rng2 = Range("T8:T12")
Set rng3 = Range("Q16:Q20")
Set rng4 = Range("T16:T20")
Set UnionRange = Union(rng1, rng2, rng3, rng4)
Dim OArr(1 To 5, 1 To 1) As Variant
Dim k As Long
k = 1
Dim i As Long
For i = DateSerial(Year(Date), Month(Date), 1) To DateSerial(Year(Date), Month(Date) + 1, 0)
If Weekday(i, vbSunday) = 6 Then
OArr(k, 1) = i
k = k + 1
End If
Next i
If k = 5 Then OArr(k, 1) = "-"
UnionRange.Value = OArr
UnionRange.NumberFormat = "dd-mmmm"
End Sub
Unfortunately, its currently not working as expected and is populating the cells with the following format:
It populates ranges Q8:Q12 and Q16:Q20 perfectly however, when filling in row T, it loops through the first friday of this month only.
Thank you all for your help with this so far. Youve all been amazingly helpful and all your time is appreciated. Special thanks to #ScottCraner for all your help with everything I have submitted so far.
You cannot fill a discontiguous union range with one array like that. Probably best to use 5 arrays or one array and slice off the pieces or run through the Areas of the unioned range.
Private Sub dateRangePayer1()
Dim unionRange As Range, uRng As Range
Dim d As Long, k As Long
Set unionRange = Worksheets("sheet8").Range("Q8:Q12, T8:T12, Q16:Q20, T16:T20")
'Set unionRange = ActiveSheet.Range("Q8:Q12, T8:T12, Q16:Q20, T16:T20") deals with the active sheet
ReDim OArr(1 To 5, 1 To 1) As Variant
For d = DateSerial(Year(Date), Month(Date), 1) To DateSerial(Year(Date), Month(Date) + 1, 0)
If Weekday(d, vbSunday) = 6 Then
k = k + 1
OArr(k, 1) = d
End If
Next d
If k = 4 Then OArr(k + 1, 1) = "-"
For Each uRng In unionRange.Areas
uRng.Value = OArr
uRng.NumberFormat = "dd-mmmm"
Next uRng
End Sub
As advised by Jeeped, I substituted the Union Range for individual references. Code changes as follows. If theres a more efficient/neater way of doing this, I would love to know:
Private Sub DateRangePayer1()
'Credit to #Pᴇʜ for pointing out the Array flaw. Corrected this.
Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range
Set rng1 = Range("Q8:Q12")
Set rng2 = Range("T8:T12")
Set rng3 = Range("Q16:Q20")
Set rng4 = Range("T16:T20")
Dim OArr(1 To 5, 1 To 1) As Variant
Dim k As Long
k = 1
Dim i As Long
For i = DateSerial(Year(Date), Month(Date), 1) To DateSerial(Year(Date), Month(Date) + 1, 0)
If Weekday(i, vbSunday) = 6 Then
OArr(k, 1) = i
k = k + 1
End If
Next i
If k = 5 Then OArr(k, 1) = "-"
rng1.Value = OArr
rng1.NumberFormat = "dd-mmmm"
rng2.Value = OArr
rng2.NumberFormat = "dd-mmmm"
rng3.Value = OArr
rng3.NumberFormat = "dd-mmmm"
rng4.Value = OArr
rng4.NumberFormat = "dd-mmmm"
End Sub
Hi I am Trying to add to cells together and compare them against another cell but I get a type mismatch.
first cell is a date, the one being added is a number"as in number of days" and the third one being compared is a date also.
but I get type mismatch.
my code is below
Sub Macro1()
Macro1 Macro
Dim wks As Worksheet
Set wks = ActiveSheet
Dim x As Integer
Dim p As Integer
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRow As Long
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowRange = wks.Range("A1:A" & LastRow)
For i = 7 To 189
p = 0
For q = 8 To LastRow
If [aq] = [si] Then
If [cq] + [ui] >= [xi] Then
[oq] = 1
Else
p = p + [dq]
[qq] = 0
End If
End If
Next q
Next i
End Sub
[cq] is a cell that contains date
[ui] is a cell that contains number
[xi] is a cell that contains date
Try it as cells(q, "A") = cells(i, "S").
For i = 7 To 189
p = 0
For q = 8 To LastRow
'If [aq] = [si] Then
If cells(q, "A") = cells(i, "S") Then
'If [cq] + [ui] >= [xi] Then
If cells(q, "C") + cells(i, "U") >= cells(i, "X") Then
'[oq] = 1
cells(q, "O") = 1
Else
'p = p + [dq]
p = p + cells(q, "D")
'[qq] = 0
cells(q, "Q") = 0
End If
End If
Next q
Next i
You need to use the "DateAdd" function. Instructions here: https://www.techonthenet.com/excel/formulas/dateadd.php
Example:
Sub add_dates()
Dim dateOne As Date
Dim dateTwo As Date
Dim lngDays As Long
dateOne = "1/1/2018"
lngDays = 2
dateTwo = "1/3/2018"
Dim result As Boolean
If DateAdd("d", lngDays, dateOne) >= dateTwo Then
MsgBox ("Greater than or equal to")
Else
MsgBox ("Less than")
End If
End Sub
I am attempting to draw data from a separate sheet and put it into a corresponding cell if the conditions are met. My code works, but it is not efficient. I do not know how to change the For Next loop so that it attempts to draw data only until the final entry. Right now I have it set to go a hundred or so cells further than I need so that I wouldn't have to update the code as often when I input new data to the data sheet (or at least that was the thought). Here is my code:
Sub LRearTest()
Dim R As Integer
Dim j As Integer
For j = 89 To 250
For R = 1 To 300
If Worksheets("Input").Cells(j, 22).Value >= Worksheets("1036L").Cells(R, 5).Value And Worksheets("Input").Cells(j, 22).Value <= Worksheets("1036L").Cells(R, 6).Value Then
Worksheets("Input").Cells(j, 20).Value = Worksheets("1036L").Cells(R, 3).Value
End If
Next R
Next j
End Sub
The problem is when I run this code it takes almost two minutes before it is over. I am not sure if it is because I have used j and r as integers or what. Also I have a dozen of these on one module so I am not sure if that contributes. The code works like I said, it is just far too slow. Help is greatly appreciated.
The point that I am checking is in Column V of Sheet "Input". Each of my columns that I want to populate, F - U, use the same data in column V. The sheets that I am comparing the data in column V against are labeled as 1030L, 1030R, 1031L, 1031R, 1032L, 1032R, 1033L, 1033R, 1034L, 1034R, 1034LA, 1034RA, 1035L, 1035R, 1036L, and 1036R. The data being compared is in the same columns in every sheet. Thank you
Something like this should work for you:
Sub LRearTest()
Dim wb As Workbook
Dim wsInput As Worksheet
Dim wsData As Worksheet
Dim aDataParams() As String
Dim aInput As Variant
Dim aData As Variant
Dim InputIndex As Long
Dim DataIndex As Long
Dim ParamIndex As Long
Dim MinCol As Long
Set wb = ActiveWorkbook
Set wsInput = wb.Sheets("Input")
'Adjust the column associations for each sheet as necessary
ReDim aDataParams(1 To 16, 1 To 3)
aDataParams(1, 1) = "1030L": aDataParams(1, 2) = "F"
aDataParams(2, 1) = "1030R": aDataParams(2, 2) = "G"
aDataParams(3, 1) = "1031L": aDataParams(3, 2) = "H"
aDataParams(4, 1) = "1031R": aDataParams(4, 2) = "I"
aDataParams(5, 1) = "1032L": aDataParams(5, 2) = "J"
aDataParams(6, 1) = "1032R": aDataParams(6, 2) = "K"
aDataParams(7, 1) = "1033L": aDataParams(7, 2) = "L"
aDataParams(8, 1) = "1033R": aDataParams(8, 2) = "M"
aDataParams(9, 1) = "1034L": aDataParams(9, 2) = "N"
aDataParams(10, 1) = "1034R": aDataParams(10, 2) = "O"
aDataParams(11, 1) = "1034LA": aDataParams(11, 2) = "P"
aDataParams(12, 1) = "1034RA": aDataParams(12, 2) = "Q"
aDataParams(13, 1) = "1035L": aDataParams(13, 2) = "R"
aDataParams(14, 1) = "1035R": aDataParams(14, 2) = "S"
aDataParams(15, 1) = "1036L": aDataParams(15, 2) = "T"
aDataParams(16, 1) = "1036R": aDataParams(16, 2) = "U"
'Find minimum column
MinCol = wsInput.Columns.Count
For ParamIndex = LBound(aDataParams, 1) To UBound(aDataParams, 1)
If wsInput.Columns(aDataParams(ParamIndex, 2)).Column < MinCol Then MinCol = wsInput.Columns(aDataParams(ParamIndex, 2)).Column
Next ParamIndex
'Based on minimum column, determine column indexes for each sheet/column pair
For ParamIndex = LBound(aDataParams, 1) To UBound(aDataParams, 1)
aDataParams(ParamIndex, 3) = wsInput.Columns(aDataParams(ParamIndex, 2)).Column - MinCol + 1
Next ParamIndex
With wsInput.Range("F89", wsInput.Cells(wsInput.Rows.Count, "V").End(xlUp))
If .Row < 89 Then
MsgBox "No data in sheet [" & wsInput.Name & "]"
Exit Sub
End If
aInput = .Value
End With
For ParamIndex = LBound(aDataParams, 1) To UBound(aDataParams, 1)
'Define data sheet based on current column
Set wsData = wb.Sheets(aDataParams(ParamIndex, 1))
aData = wsData.Range("C1", wsData.Cells(wsData.Rows.Count, "F").End(xlUp)).Value
For InputIndex = LBound(aInput, 1) To UBound(aInput, 1)
For DataIndex = LBound(aData, 1) To UBound(aData, 1)
If aInput(InputIndex, UBound(aInput, 2)) >= aData(DataIndex, 3) _
And aInput(InputIndex, UBound(aInput, 2)) <= aData(DataIndex, 4) Then
aInput(InputIndex, aDataParams(ParamIndex, 3)) = aData(DataIndex, 1)
Exit For
End If
Next DataIndex
Next InputIndex
Set wsData = Nothing
Erase aData
Next ParamIndex
wsInput.Range("F89").Resize(UBound(aInput, 1), UBound(aInput, 2)) = aInput
Set wb = Nothing
Set wsInput = Nothing
Set wsData = Nothing
Erase aInput
Erase aData
Erase aDataParams
End Sub
I received help in solving a previous question. I would like to solve this problem similarly.
So the situation is similar to a Countifs function, in that I would like it to count if a range equals a certain building, as well as if the date and time that is offset equals a certain date. For example, if the cell in "C1" = "Irving Building" And if the value in "K1" = "Monday" Then I would like it to display in "S1". More specifically if "C1" = "Irving Building" then I want it to count into whatever day and time that corresponds with it, in Column K.
Private Sub TimeAndDate()
Dim n As Double
Dim rep As Worksheet
Dim ws As Worksheet
Dim LastRow As Double
Set rep = Worksheets("Report")
rep.Columns("K:L").ClearContents
For n = 1 To ThisWorkbook.Sheets.Count
Set ws = Worksheets(n)
If IsNumeric(ws.Name) Then
LastRow = rep.Range("K1", rep.Range("K1").End(xlDown)).Rows.Count
LastRow = LastRow + 1
If rep.Range("K1") = "" Then
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("K1")
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("L1")
Else:
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("K" & LastRow)
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("L" & LastRow)
End If
End If
Next n
Dim rDts As Range
Dim vDts As Variant
Dim vCnts As Variant
Dim vAP As Variant 'for the AM PM count
Dim vDbld As Variant 'for the date by building
Dim vTbld As Variant 'for thee time by building
Dim i As Long, J As Long
'read dates into array -- faster processing
With rep
vDts = .Range(.Cells(1, 11), .Cells(.Rows.Count, 11).End(xlUp))
End With
'Results array
ReDim vCnts(1 To 7, 1 To 2)
vCnts(1, 1) = "Sunday"
vCnts(2, 1) = "Monday"
vCnts(3, 1) = "Tuesday"
vCnts(4, 1) = "Wednesday"
vCnts(5, 1) = "Thursday"
vCnts(6, 1) = "Friday"
vCnts(7, 1) = "Saturday"
ReDim vAP(1 To 2, 1 To 2)
vAP(1, 1) = "AM"
vAP(2, 1) = "PM"
ReDim vDbld(1 To 13, 1 To 2)
vDbld(1, 1) = "Irving Building"
vDbld(2, 1) = "Memorial Building"
vDbld(3, 1) = "West Tower"
vDbld(4, 1) = "Witting Surgical Center"
vDbld(5, 1) = "Madison Irving Surgical Center"
vDbld(6, 1) = "Marley Education Center"
vDbld(7, 1) = "410 South Crouse"
vDbld(8, 1) = "Physicians Office Building"
vDbld(9, 1) = "Crouse Business Center"
vDbld(10, 1) = "Commonwealth Place"
vDbld(11, 1) = "Irving - Memorial Connector"
vDbld(12, 1) = "Crouse Garage"
vDbld(13, 1) = "CNY Medical Center"
'Do the counts
For i = 1 To UBound(vDts, 1)
J = Weekday(vDts(i, 1))
vCnts(J, 2) = vCnts(J, 2) + 1
If Hour(vDts(i, 1)) < 12 Then
vAP(1, 2) = vAP(1, 2) + 1
Else
vAP(2, 2) = vAP(2, 2) + 1
End If
Next i
'output the results
rep.Range("E1:E14").Copy rep.Range("Q1")
rep.Range("N2:N8").Copy
rep.Range("R1").PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, _
False, True
rep.Range("N11:N12").Copy
rep.Range("Y1").PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, _
False, True
rep.Range("N1") = "DATE"
rep.Range("O1") = "COUNT"
rep.Range("N10") = "TIME"
rep.Range("O10") = "COUNT"
rep.Range("N2:O8").Value = vCnts
rep.Range("N11:O12").Value = vAP
The part that I am needing help on is this part here. These are the variants that I'd like to use, but like I said, earlier, I am unsue as to how to do this without running a ton of countifs statements.
Dim vDbld As Variant 'for the date by building
ReDim vDbld(1 To 13, 1 To 2)
vDbld(1, 1) = "Irving Building"
vDbld(2, 1) = "Memorial Building"
vDbld(3, 1) = "West Tower"
vDbld(4, 1) = "Witting Surgical Center"
vDbld(5, 1) = "Madison Irving Surgical Center"
vDbld(6, 1) = "Marley Education Center"
vDbld(7, 1) = "410 South Crouse"
vDbld(8, 1) = "Physicians Office Building"
vDbld(9, 1) = "Crouse Business Center"
vDbld(10, 1) = "Commonwealth Place"
vDbld(11, 1) = "Irving - Memorial Connector"
vDbld(12, 1) = "Crouse Garage"
vDbld(13, 1) = "CNY Medical Center"
I apologize if this is confusing, I am not completely sure how to word it, thanks in advance.
This is an example of what I'd like it to look like:
What you simply can is to check with Application.Match if the string is in the array and it will give back the index, because this function can only handle one dimensional arrays, there is another function that will give back one dimension of the array. After that you can check the offset and do something with it like this:
Dim mindex as Variant
mindex = Application.Match(rDts(i, 3), Only1D(vDbld, 1), 0)
If Not IsError(mindex) Then
'do stuff i.e
vDbld(mindex, 2) = vDbld(mindex, 2) + 1
End If
Function Only1D(arr As Variant, d As Long)
Dim size As Long: size = UBound(arr, d)
Dim arr2 As Variant
ReDim arr2(1 To size)
For i = 1 To size
arr2(i) = arr(i, d)
Next
Only1D = arr2
End Function
I have a list of columns with Month/Year as title (like JAN09, FEB09, AUG10). I have to check if the months are sequentially aligned. if not then align it and if a specific month is not available then create a column name title as the month name and go ahead. I have written a code but it works for the first year (like from year 09-11, it will identify all the months of 09 but after that it fails to identify and creates a new month every time even if it is present).
Sub MonthFinder()
Dim montharray As Variant
montharray = Array("JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")
lastrow = ActiveSheet.UsedRange.Rows.Count + 5
lastcol = ActiveSheet.UsedRange.Columns.Count
minmonth = Right(Cells(5, 2), 2)
range0 = 2
maxmonth = Right(Cells(5, 2), 2)
Do Until range0 > lastcol
If Right(Cells(5, range0), 2) < minmonth Then
minmonth = Right(Cells(5, range0), 2)
End If
If Right(Cells(5, range0), 2) > maxmonth Then
maxmonth = Right(Cells(5, range0), 2)
End If
range0 = range0 + 1
Loop
minsortmonth = minmonth
maxsortmonth = maxmonth
place = 2
Do Until minsortmonth = maxsortmonth + 1
arraycount = 0
Do Until arraycount = 12
range1 = 2
lastcol = ActiveSheet.UsedRange.Columns.Count
Do Until Left(Cells(5, range1), 3) = montharray(arraycount) And Right(Cells(5, range1), 2) = minsortmonth Or range1 > lastcol
range1 = range1 + 1
Loop
If range1 > lastcol Then
Range(Cells(5, place), Cells(lastrow, place)).Select
Selection.Insert Shift:=xlToRight
Cells(5, place).Value = montharray(arraycount) & minsortmonth
Else
If range1 <> place Then
Range(Cells(5, range1), Cells(lastrow, range1)).Cut
Cells(5, place).Select
Selection.Insert Shift:=xlToRight
End If
End If
arraycount = arraycount + 1
place = place + 1
Loop
minsortmonth = minsortmonth + 1
Loop
End Sub
I'd suggest to change the logic you do and to use Dictionary.
Let's say your data (columns) are initially sorted as follow: JAN09, FEB09, APR09...MAR00, MAY00, JUL00, ..., etc. There are some gaps in months collection and you want to fill in missing months. Here is an idea:
'Note: columns are initially sorted!
Sub CheckMonthSequence()
Dim dic As Dictionary
Dim element As Variant
Dim col As Integer, pos As Integer, rng As Range
Dim initialDate As Date, endDate As Date, sTmp As String
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("B5")
'define initial date as January of ...
sTmp = rng
sTmp = "01/01/" & "20" & Right(sTmp, 2)
initialDate = CDate(sTmp)
'define end date
sTmp = rng.End(xlToRight)
sTmp = Left(sTmp, 3) & "/01/" & "20" & Right(sTmp, 2)
endDate = CDate(sTmp)
'create new dictionary with collection of months
Set dic = GetMonthsAsDictionary(initialDate, endDate)
'define a range of columns to sort and update
col = 0
Do While rng.Offset(, col) <> ""
element = rng.Offset(, col)
If dic.Exists(element) Then
pos = dic.Item(element)
If pos > col Then
Do While col < pos
rng.Offset(, col).EntireColumn.Insert xlShiftToRight
'sometimes it loses the reference, so...
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("B5")
rng.Offset(, col) = GetKeyByIndex(dic, col)
col = col + 1
Loop
col = pos
End If
End If
col = col + 1
Loop
End Sub
'needs reference to MS Scripting Runtime
Function GetMonthsAsDictionary(ByVal StartingMonth As Date, EndMonth As Date) As Dictionary
Dim dic As Dictionary
Dim i As Integer, j As Integer
'create new dictionary
Set dic = New Dictionary
i = 0
j = DateDiff("M", StartingMonth, EndMonth)
For i = 0 To j
dic.Add UCase(Format(DateAdd("M", i, StartingMonth), "MMMyy")), i
Debug.Print UCase(Format(DateAdd("M", i, StartingMonth), "MMMyy")), i
Next
Set GetMonthsAsDictionary = dic
End Function
Function GetKeyByIndex(ByVal dic As Dictionary, ByVal ind As Integer) As String
Dim dic_Keys As Variant, element As Variant
dic_Keys = dic.keys
For Each element In dic_Keys
If dic.Item(element) = ind Then
Exit For
End If
Next
GetKeyByIndex = element
End Function
As you can see, above code:
1) create dictionary which contains months and corrensponding index.
2) loops through the collection of columns
3) checks that value corresponds to index in a dictionary
4) fill in header when it's necessary.
I know, it's not perfect, but good point to start.
CheersMaciej
[EDIT]
Using your logic, the code might look like:
Option Explicit 'do not apply initialize variable without its declaration
Sub MonthFinder()
Dim montharray As Variant, rng As Range
Dim firstyear As Integer, lastyear As Integer, curryear As Integer
Dim curroffset As Integer, lastcol As Integer, currmonth As Integer
curroffset = 0
montharray = Array("JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")
'start here:
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("B5")
'first year
firstyear = CInt(Right(rng, 2))
'fid last col
lastcol = rng.End(xlToRight).Column - rng.Column
'find last year
lastyear = CInt(Right(rng.Offset(ColumnOffset:=lastcol), 2))
For curryear = firstyear To lastyear
For currmonth = LBound(montharray) To UBound(montharray)
'if current month is equal to last month - exit for
If CStr(montharray(currmonth) & curryear) = CStr(rng.End(xlToRight)) Then Exit For
'month is proper - do nothing
If rng.Offset(ColumnOffset:=curroffset) = CStr(montharray(currmonth) & curryear) Then GoTo SkipMonth
'other cases
rng.Offset(ColumnOffset:=curroffset).EntireColumn.Insert xlShiftToRight
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("B5")
rng.Offset(ColumnOffset:=curroffset) = CStr(montharray(currmonth) & curryear)
SkipMonth:
curroffset = curroffset + 1
Next
Next
Set rng = Nothing
End Sub
Cheers,
Maciej