.
The following macro (CollectProjectItems) functions as designed. Applying the same logic, with a change in the Range, in the macro (CollectContractorItems) does not function as desired.
I am presuming the error is something I've overlooked and of course ... for the life of me ... I cannot identify my error.
Need a fresh set of eyes.
Thank you ahead of time.
Sub UpdateCharts()
CollectProjectItems
CollectContractorItems
End Sub
Sub CollectProjectItems()
On Error Resume Next
MyDate = Format(Date, "mmm") & "-" & Right(Year(Date), 2)
For Each cl In Range("A3", Range("A" & Rows.Count).End(xlUp))
wproj = Application.Match(cl.Value, Columns(10), 0)
If IsNumeric(wproj) Then
MyMonth = Application.Match(MyDate, Rows(wproj + 1), 0)
Cells(wproj + 2, MyMonth) = cl.Offset(, 1)
Cells(wproj + 3, MyMonth) = cl.Offset(, 2)
End If
Next
End Sub
Sub CollectContractorItems()
On Error Resume Next
MyDate = Format(Date, "mmm") & "-" & Right(Year(Date), 2)
For Each cl In Range("E3", Range("E" & Rows.Count).End(xlUp))
wproj = Application.Match(cl.Value, Columns(25), 0)
If IsNumeric(wproj) Then
MyMonth = Application.Match(MyDate, Rows(wproj + 1), 0)
Cells(wproj + 2, MyMonth) = cl.Offset(, 1)
Cells(wproj + 3, MyMonth) = cl.Offset(, 2)
End If
Next
End Sub
The second macro does not complete the required edits in Col AG. It duplicates the same edit as the first macro for Col R.
I don't understand how to change the second macro so it affects edits in Cols Z:AK .
???
Download example workbook : Macro Error
Like this:
Sub CollectContractorItems()
Const COL_CONTRACTORS As Long = 25
Dim MyDate As String, cl As Range, ws As Worksheet, wproj, MyMonth
Dim rngDates As Range, dtCol As Long
Set ws = ActiveSheet 'or some specific sheet
MyDate = Format(Date, "mmm") & "-" & Right(Year(Date), 2)
For Each cl In ws.Range("E3:E" & ws.Cells(ws.Rows.Count, "E").End(xlUp).Row).Cells
wproj = Application.Match(cl.Value, ws.Columns(COL_CONTRACTORS), 0)
If Not IsError(wproj) Then
'get the range with dates
Set rngDates = ws.Cells(wproj, COL_CONTRACTORS).Offset(1, 1).Resize(1, 12)
MyMonth = Application.Match(MyDate, rngDates, 0) 'search only in the specific range
If Not IsError(MyMonth) Then
dtCol = rngDates.Cells(MyMonth).Column 'get the column number
ws.Cells(wproj + 2, dtCol) = cl.Offset(, 1)
ws.Cells(wproj + 3, dtCol) = cl.Offset(, 2)
End If
End If
Next
End Sub
Related
I'm new using VBA and I'm trying to code into VBA but it didn't work so far, my timestamp data is not common and I got 10000+ rows to do the same formula (sometime excel just crash so i would like to try VBA)
timestamp that I tried split
Edit : add code
Sub Split_text_3()
Dim p As String
For x = 1 To 6 '---How do it until last cell?
Cells(x, 2).Value = Mid(Cells(x, 1).Value, 9, 2) 'combind in same cell
Cells(x, 3).Value = Mid(Cells(x, 1).Value, 5, 3) 'combind in same cell
Cells(x, 4).Value = Mid(Cells(x, 1).Value, 21, 4) 'combind in same cell
Cells(x, 5).Value = Mid(Cells(x, 1).Value, 12, 8)
Next x End Sub
and the data look like this (I tried to separate it first and then might try to combine them later)
image
Please, try the next function:
Function extractDateTime(strTime As String) As Variant
Dim arrD, d As Date, t As Date
arrD = Split(strTime, " ")
d = CDate(arrD(2) & "/" & arrD(1) & "/" & arrD(4))
t = CDate(arrD(3))
extractDateTime = Array(d, t)
End Function
It can be tested in the next way:
Sub testExtractDate()
Dim x As String, arrDate
x = "WED SEP 08 08:13:52 2021"
arrDate = extractDateTime(x)
Debug.Print arrDate(0), arrDate(1)
End Sub
If it returns as you need (I think, yes...), you can use the next function to process the range. It assumes that the column keeping the strings are A:A, and returns in C:D:
Sub useFunction()
Dim sh As Worksheet, lastR As Long, Arr, arrDate, arrFin, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
Arr = sh.Range("A2:A" & lastR).Value
If IsArray(Arr) Then
ReDim arrFin(1 To UBound(Arr), 1 To 2)
For i = 1 To UBound(Arr)
If Arr(i, 1) <> "" Then
arrDate = extractDateTime(CStr(Arr(i, 1)))
arrFin(i, 1) = arrDate(0): arrFin(i, 2) = arrDate(1)
End If
Next i
sh.Range("C2").Resize(UBound(arrFin), 2).Value = arrFin
Else
sh.Range("C2:D2").Value = extractDateTime(CStr(sh.Range("A2").Value))
End If
End Sub
I think I have another solution (not bulletproof) but it is simplier, quicker and code less solution (no offense FraneDuru!):
Sub DateStamp()
Dim arr, arr_temp, arr_new() As Variant
Dim i As long
'Take cells from selected all the way down to 1st blank cell
'and assign values to an array
arr = ThisWorkbook.ActiveSheet.Range(Selection, Selection.End(xlDown)).Value
ReDim Preserve arr_new(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
'Make another array by spliting input string by whitespace delimiter (default)
arr_temp = Split(arr(i, 1))
'Construct values in desired "format"
arr_new(i, 1) = "'" & arr_temp(2) & "/" & arr_temp(1) & "/" & arr_temp(4)
arr_new(i, 2) = arr_temp(3)
Next i
'Paste result into Excel
Selection.Offset(0, 1).Resize(UBound(arr), 2) = arr_new
End Sub
All you have to do is to select the cell toy want to start with and run the macro! :)
Bellow also a picture with watches, so you can catch-up what is going on:
i tried using dictionary but it only counts the repetition but i want to know the exact frequency of all datas in a column
what ive used is
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
End If
Next x
items.RemoveAll
End Sub
and this gives me
[1: https://i.stack.imgur.com/Mhp5g.png][1]
but what i need is
[4: https://i.stack.imgur.com/UYOFu.png][4]
I think this is what you were after. Please try it.
Sub CountThings()
Dim Ws As Worksheet
Dim Items As Object ' Scripting.Dictionary
Dim Arr As Variant ' values in column B
Dim R As Long ' loop couner: Rows
Dim Key As Variant ' loop counter: dictionary keys
Set Items = CreateObject("Scripting.Dictionary")
Set Ws = ActiveSheet ' better: define tab by name
With Ws
' reading from the sheet is slow
' therefore read all items at once
Arr = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value
' this is a 1-based 2-D array, like Arr([Rows], [Column])
' where column is always 1 because there's only 1 column
End With
For R = 1 To UBound(Arr)
If Items.Exists(Trim(Arr(R, 1))) Then
Items(Trim(Arr(R, 1))) = Items(Trim(Arr(R, 1))) + 1
Else
Items.Add Trim(Arr(R, 1)), 1
End If
Next R
ReDim Arr(1 To Items.Count, 1 To 2)
R = 0
For Each Key In Items.keys
R = R + 1
Arr(R, 1) = Key
Arr(R, 2) = Items(Key)
Next Key
' specify the top left cell of the target range
Ws.Cells(2, "C").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
Set Items = Nothing
End Sub
You need not Trim the Keys if you are sure that there can't be any stray leading or trailing blanks.
Your second picture doesn't need VBA. It can be produce by this formula, entered in C2 and copied down.
=COUNTIF($B$2:$B$13,$B2)
In fact, you can even do the job of my above code without VBA. Enter this formula in G2 of your sheet as an array formula (confirmed with CTL + SHIFT + ENTER if you don't have Excel 365), and the other one in H. Then copy both formulas down.
[G2] =IFERROR(INDEX($B$2:$B$13, MATCH(0, COUNTIF($G$1:G1, $B$2:$B$13), 0)), "")
[H2] =IF($G2<>"",COUNTIF($B$2:$B$13,$G2),"")
You need to assign values to column C after you have finished counting and therefore, need another loop:
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
End If
Next x
For x = 2 To lastrow
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Next x
items.RemoveAll
Set items = Nothing
End Sub
A simpler way to achieve what you want is to let excel do the counting for you like this:
Sub countThings2()
Dim sDataAddress As String
With ActiveSheet
sDataAddress = "$B$2:$B$" & .Cells(Rows.Count, "B").End(xlUp).Row
With .Range(sDataAddress).Offset(0, 1)
.Formula2 = "=COUNTIF(" & sDataAddress & ",B2)"
.Value = .Value
End With
End With
End Sub
i use table and 2 functions. not simple way but works :)
Sub Fx()
Dim str_Tab() As String, str_Text As String, str_Result As String
Dim int_Counter As Integer, int_TabItemCounter As Integer, int_LastRow As Integer
Dim rng_WorkRange As Range
int_LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set rng_WorkRange = ActiveSheet.Range("A1:A" & int_LastRow)
For i = 1 To int_LastRow
str_Text = ActiveSheet.Range("A" & i)
If i > 1 Then
str_Result = IsInArray(str_Text, str_Tab)
If str_Result = -1 Then
int_TabItemCounter = UBound(str_Tab) - LBound(str_Tab)
ReDim str_Tab(int_TabItemCounter)
str_Tab(int_TabItemCounter) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
Else
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If str_Result = -1
Else ' If i > 1
ReDim str_Tab(i)
str_Tab(i) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If i > 1
Next i
End Sub
function to check is text in table
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim i As Long
' default return value if value not found in array
IsInArray = -1
For i = LBound(arr) To UBound(arr)
If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
IsInArray = i
Exit For
End If
Next i
End Function
function to count item in range
Function CountThisItem(CountingRange As Range, a As String) As Integer
Dim rng_FindRange As Range
Dim LA As String
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole)
If Not rng_FindRange Is Nothing Then
LA = rng_FindRange.Address
CountThisItem = 1
Do
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole, after:=rng_FindRange)
If Not rng_FindRange Is Nothing And rng_FindRange.Address <> LA Then CountThisItem = CountThisItem + 1
Loop While rng_FindRange.Address <> LA
Else
CountThisItem = 0
End If
End Function
I need to create a VBA script in excel that chanages an order number from having "CD" at the front to "CD" at the end so from "CD00001" to "00001CD"
Any help would be awesome. all of the order numbers are in Column B and start at row 5. please help.
What i have so far:
Private Sub OrderNumber_Click()
Dim Val As String
Dim EndC As Integer
EndC = Worksheets("Raw Data Upload").Range("A1048576").End(xlUp).Row
For i = 5 To EndC
Val = Right("B" & i, Len("B" & i) - 2) & Left("B" & i, 2)
Range("B" & i).Value = Val
Next
End Sub
This replaces the order numbers with B5, B6 and so on but if i put this function into Excel itself it works fine.
Like this? DO you want it in column B?
Option Explicit
Private Sub OrderNumber_Click()
Dim i As Long
Dim val As String
Dim EndC As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Raw Data Upload")
EndC = ws.Range("A1048576").End(xlUp).Row
For i = 5 To EndC
val = ws.Cells(i, "A")
Range("B" & i).Value = Mid$(val, 3, Len(val) - 2) & Left$(val, 2)
Next i
End Sub
dim beginStr, endStr, originalStr, outputStr as string
dim rng as range
'put the below into a loop, assigning a rng to the desired cell each time
originalStr = rng.value ' Change to chosen range
beginStr = left(originalStr,2)
endStr = right(originalStr, len(originalStr) - 2)
outputStr = endStr + beginStr
Range("B" & i).Value = outputStr
I haven't got a copy of Excel to test this on but it should work.
Simply use:
Right(Range("B" & i), Len(Range("B" & i)) - 2) & Left(Range("B" & i), 2)
An alternative is to set up the cell as a Range():
Sub t()
Dim cel As Range
Dim endC As Long
endC = Worksheets("Raw Data Upload").Range("A1048576").End(xlUp).Row
For i = 5 To endC
Set cel = Range("B" & i)
myVal = Right(cel, Len(cel) - 2) & Left(cel, 2)
Range("B" & i).Value = myVal
Next
End Sub
Currently, when you do Right("B" & i, Len("B" & i) - 2) & Left("B" & i, 2), for row 5, this becomes Right("B5", Len("B5") - 2) & Left("B5", 2) then this evaluates to simply:
Right("B5",0) & Left("B5",2), which is
[nothing] & B5, finally becoming
B5
Note the lack of using B5as a range. Instead it's being treated as a string.
(Also, I'm assuming this is to be run on the ActiveSheet. If not, please add the worksheet before the range, i.e. Worksheets("Raw Data Upload").Range("B" & i)...)
Try this
Private Sub OrderNumber_Click()
Dim cell As Range
With Worksheets("Raw Data Upload")
For Each cell in .Range("B5", .Cells(.Rows.Count, 2).End(xlUp))
cell.Value = Right(cell.Value, Len(cell.Value) - 2) & Left(cell.Value, 2)
Next
End With
End Sub
I have problem with closing one userform and going to next. UserForm3 after clicking command button should be closed and UserForm4 should be shown. Unfortunately I get "Run time Error 91 object variable or with block variable not set". I've dug deep into internet and I am pretty sure that problem is with Userform4, although code for UserForm3 is highlighted as bugged. Basicly I want UserForm4 to be displayed and have all the textboxes filled with data from sheet "Log", based on choice from Combobox from UserForm3. Choice from UserForm3 is saved to cell E1 on "Log" Sheet.
Code from UserForm3
Private Sub CommandButton1_Click()
Sheets("Log").Range("E1") = ComboBox2.Text
Unload Me
UserForm4.Show <- ERROR DISPLAYED HERE
End Sub
In UserForm4 I want to find value from E1 in cells below and later on fill textboxes in Userform4 with data from the row, in which E1 value was found.
Code for UserForm4
Private Sub UserForm_Initialize()
Dim Name As String
Dim rng As Range
Dim LastRow As Long
Dim wart As Worksheet
wart = Sheets("Log").Range("E1")
LastRow = ws.Range("B3" & Rows.Count).End(xlUp).Row + 1
Name = Sheets("Log").Range("E1")
UserForm4.TextBox8.Text = Name
nazw = Application.WorksheetFunction.VLookup(wart, Sheets("Log").Range("B3:H" & LastRow), 1, False)
UserForm4.TextBox1.Text = ActiveCell.Offset(, 1)
UserForm4.TextBox2.Text = ActiveCell.Offset(, 1)
UserForm4.TextBox3.Text = ActiveCell.Offset(, 1)
UserForm4.TextBox4.Text = ActiveCell.Offset(, 1)
UserForm4.TextBox5.Text = ActiveCell.Offset(, 1)
UserForm4.ComboBox1.Text = ActiveCell.Offset(, 1)
UserForm4.TextBox6.Text = ActiveCell.Offset(, 1)
UserForm4.TextBox7.Text = ActiveCell.Offset(, 1)
End Sub
The code below is to avoid to run-time errors mentioned in the code above, it's not debugged for the VLookup function part.
Option Explicit
Private Sub UserForm_Initialize()
Dim Name As String
Dim LastRow As Long
Dim wart As Variant
Dim ws As Worksheet
Dim nazw As Long
' set ws to "Log" sheets
Set ws = Sheets("Log")
With ws
wart = .Range("E1")
' method 1: find last row in Column "B" , finds last row even if there empty rows in the middle
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
' method 2 to find last row, equivalent to Ctrl + Shift + Down
' LastRow = .Range("B3").CurrentRegion.Rows.Count + 1
' a little redundant with the line 2 above ?
Name = .Range("E1")
End With
With Me
.TextBox8.Text = Name
' ****** Need to use Match instead of Vlookup VLookup Section ******
If Not IsError(Application.Match(wart, ws.Range("B1:B" & LastRow - 1), 0)) Then
nazw = Application.Match(wart, ws.Range("B1:B" & LastRow - 1), 0)
Else ' wart record not found in range
MsgBox "Value in Sheet " & ws.Name & " in Range E1 not found in Column B !", vbInformation
Exit Sub
End If
.TextBox1.Text = ws.Range("B" & nazw).Offset(, 1)
.TextBox2.Text = ws.Range("B" & nazw).Offset(, 1)
.TextBox3.Text = ws.Range("B" & nazw).Offset(, 1)
.TextBox4.Text = ws.Range("B" & nazw).Offset(, 1)
.TextBox5.Text = ws.Range("B" & nazw).Offset(, 1)
.ComboBox1.Text = ws.Range("B" & nazw).Offset(, 1)
.TextBox6.Text = ws.Range("B" & nazw).Offset(, 1)
.TextBox7.Text = ws.Range("B" & nazw).Offset(, 1)
End With
End Sub
My spreadsheet is used to manage tasks. I add new tasks by running a small macro, and currently the numbering is simply 1, 2, 3, 4..., generated by the following code:
Cells(ActiveSheet.Rows(9).Row, 1).Value = Cells(ActiveSheet.Rows(10).Row, 1).Value + 1
I would like, using VBA, to evolve this by adding a prefix to the number that represents the Year the task was initiated. Furthermore, the numbering should re-start at 1 for the first entry of each year. I.e
15-1, 15-2, 15-3, 15-4....16-1, 16-2, 16-3...
Any ideas for a simple code that could achieve this?
Here is a very basic example. Amend it to suit your needs. You can also create a procedure and pass the row number to which you want the auto numbering to happen as shown at the end of this post.
Sub Sample()
Dim rng As Range
Dim prev As Range
Dim rw As Long
rw = 9 '<~~ Change this to the relevant row
Set rng = ThisWorkbook.Sheets("Sheet1").Cells(rw, 1)
On Error Resume Next
Set prev = rng.Offset(-1)
On Error GoTo 0
'~~> Check if there is one row above
If Not prev Is Nothing Then
'~~> Match the year
If Left(rng.Offset(-1), 2) <> Format(Date, "yy") Then
'~~> Restart numbering
rng.Value = Format(Date, "yy") & "-" & 1
Else
'~~> Increment numbering. Split will extract the number
rng.Value = Format(Date, "yy") & "-" & Val(Split(rng.Value, "-")(1)) + 1
End If
Else
'~~> Restart numbering
rng.Value = Format(Date, "yy") & "-" & 1
End If
End Sub
Screenshot
Edit:
Using it as a procedure where you can pass arguments.
Sub Sample()
Dim r As Long
r = 9 '<~~ Chnage this to the relevant row
AllocateID r
End Sub
Sub AllocateID(rw As Long)
Dim rng As Range
Dim prev As Range
Set rng = Cells(rw, 1)
On Error Resume Next
Set prev = rng.Offset(-1)
On Error GoTo 0
'~~> Check if there is one row above
If Not prev Is Nothing Then
'~~> Match the year
If Left(rng.Offset(-1), 2) <> Format(Date, "yy") Then
'~~> Restart numbering
rng.Value = Format(Date, "yy") & "-" & 1
Else
'~~> Increment numbering. Split will extract the number
rng.Value = Format(Date, "yy") & "-" & Val(Split(rng.Value, "-")(1)) + 1
End If
Else
'~~> Restart numbering
rng.Value = Format(Date, "yy") & "-" & 1
End If
End Sub
How about this:
Sub Test()
Dim i As Integer
Dim startYear As Integer
priorYear = 2014
With ActiveSheet
For i = 1 To 100
.Cells(i, 1) = CStr(priorYear + WorksheetFunction.RoundUp(i / 12, 0) & "-" & ((i + 1) Mod 12))
Next i
End With
End Sub
sure just do that:
Cells(ActiveSheet.Rows(9).Row, 1).Value = format(date,"yy") & "-" & _
Cells(ActiveSheet.Rows(10).Row, 1).Value + 1