This is the updated code. I am getting a mismatch error now. It would be great if someone could offer some help. Thanks in advance!
Sub Macro2()
Dim rowcount As Long
Dim target As Variant, startcell4 As Range
Set startcell4 = ActiveSheet.Cells(2, 1)
rowcount = Range(Range("E2"), Range("E2").End(xlDown)).Rows.Count
For i = 2 To rowcount + 1
If Not ActiveSheet.Cells(i, 26) = ActiveSheet.Cells(i + 1, 26) Then
Set target = Application.Match(ActiveSheet.Cells(i, 26), Worksheets(19).Range("A6:A3000"), 0)
If Not IsError(target) Then
ActiveSheet.startcell4.Offset(0, 17).Value = Worksheets(19).Cells(target + 6, 10)
Set startcell4 = ActiveSheet.Cells(i + 1, 26)
End If
End If
Next i
End Sub
Changed:
"Set target = ..." to "target = ..."
"ActiveSheet.startcell4" to "startcell4"
A little refactoring
Coming to this
Sub Macro2()
Dim rowcount As Long
Dim target As Variant, startcell4 As Range
Set startcell4 = Cells(2, 1)
rowcount = Range("E2").End(xlDown).Row
For i = 2 To rowcount
If Not Cells(i, 26) = Cells(i + 1, 26) Then
target = Application.Match(Cells(i, 26), Worksheets(19).Range("A6:A3000"), 0)
If Not IsError(target) Then
startcell4.Offset(0, 17).Value = Worksheets(19).Cells(target + 6, 10)
Set startcell4 = Cells(i + 1, 26)
End If
End If
Next i
End Sub
Related
I was working on a project to extract the data from API and Parsing it through the relevant column. The first one is working very fine but its optimizing speed is extremely slow.
so i though to convert it into arrays for fast processing but geeting Run-time error 9 Subscript out of range`
Your help will be much appreciated to fix the issue.
First code with slow optimization.
Dim json As Object
Dim timeEntry As Object
Dim ti As Object
Dim lastRow As Long
Dim myValue As String
Set json = JsonConverter.ParseJson(Data)
i = 2
lastRow = Sheet2.Range("A1").End(xlUp).Row
For Each timeEntry In json("timeentries")
With Sheet2.Cells(i, 1)
.Value = timeEntry("projectName")
.Offset(0, 4).Value = timeEntry("taskName")
.Offset(0, 8).Value = timeEntry("description")
.Offset(0, 9).Value = timeEntry("clientName")
End With
Set ti = timeEntry("timeInterval")
With Sheet2.Cells(i, 1)
.Offset(0, 10).Value = ti("start")
.Offset(0, 6).Value = ti("duration")
End With
i = i + 1
Next timeEntry
Second code with Arrays and getting error
Dim json As Object
Dim timeEntry As Object
Dim ti As Object
Dim lastRow As Long
Dim myValue As String
Set json = JsonConverter.ParseJson(Data)
i = 2
lastRow = Sheet2.Range("A1").End(xlUp).Row
Dim dataArray() As Variant
ReDim dataArray(1 To lastRow, 1 To 12)
For Each timeEntry In json("timeentries")
dataArray(i, 1) = timeEntry("projectName")
dataArray(i, 5) = timeEntry("taskName")
dataArray(i, 9) = timeEntry("description")
dataArray(i, 10) = timeEntry("clientName")
Set ti = timeEntry("timeInterval")
dataArray(i, 11) = ti("start")
dataArray(i, 7) = ti("duration")
i = i + 1
Next timeEntry
Sheet2.Range("A2").Resize(lastRow, 12).Value = dataArray
Size array to number of entries
Sub demo()
Dim json As Object, t As Object
Dim data, i As Long, n As Long
data = "{'timeentries':[" & _
"{'projectName':'Name1','taskName':'Task1','timeInterval':{'start':'08:00','duration':'123'}}," & _
"{'projectName':'Name2','taskName':'Task2','timeInterval':{'start':'09:00','duration':'234'}}," & _
"{'projectName':'Name3','taskName':null,'timeInterval':{'start':'10:00','duration':'345'}}]}"
Set json = JsonConverter.ParseJson(data)
n = json("timeentries").Count
If n < 1 Then
MsgBox "No timeentries in JSON", vbCritical
Exit Sub
End If
Dim dataArray() As Variant
ReDim dataArray(1 To n, 1 To 6)
i = 1
For Each t In json("timeentries")
dataArray(i, 1) = t("projectName") '1
If Not IsNull(t("taskName")) Then
dataArray(i, 2) = t("taskName") '5
End If
dataArray(i, 3) = t("description") '9
dataArray(i, 4) = t("clientName") '10
dataArray(i, 5) = t("timeInterval")("start") '11
dataArray(i, 6) = t("timeInterval")("duration") '77
i = i + 1
Next
' columns
Dim col: col = Array(1, 5, 9, 10, 11, 7)
For i = 0 To UBound(col)
Sheet2.Cells(2, col(i)).Resize(n) = WorksheetFunction.Index(dataArray, 0, i + 1)
Next
End Sub
I got problem with calendar in VBA. Wants to create a calendar that will show/paint the range of week numbers from 2022 depending on the date entered in columns A22 and B22. The problem occurs when the week numbers repeat between months.
Tydzien = Week
Sty = January
Lut = February
Option Explicit
Sub Kolorowaniedaty()
Dim rok As Integer
rok = Left(Cells(22, 2), 4)
Dim miesiacpocz As Integer
miesiacpocz = Mid(Cells(22, 2), 7, 1)
Dim miesiackon As Integer
miesiackon = Mid(Cells(22, 3), 7, 1)
Dim Datapocz As Integer
Datapocz = Application.WorksheetFunction.WeekNum(Cells(22, 2), 2)
Dim Datakon As Integer
Datakon = Application.WorksheetFunction.WeekNum(Cells(22, 3), 2)
Dim Rokzdaty As String
Rokzdaty = CStr(Mid(Cells(22, 2), 3, 2))
Dim Rok2022 As Byte
Rok2022 = 22
Dim kolumna As Byte
For kolumna = 1 To 20
If Rokzdaty = Rok2022 And miesiacpocz = miesiackon Then
Range(Cells(22, Datapocz + 4), Cells(22, Datakon + 4)).Interior.Color = vbYellow
Else: Range(Cells(22, Datapocz + 4), Cells(22, Datakon + 5)).Interior.Color = vbYellow
End If
Next kolumna
End Sub
I cant upload image of Makro and Calendar from excel cuz i dont have enought points of reputations. If someone can help from private chat i will be really really thankful. Its must have from to my work.
[![enter image description here][3]][3]
Its Its suppose to mark 11 weeks but its show only 10 weeks. Any advice?
[3]: https://i.stack.imgur.com/X8kwQ.png
Iterate over each day in the date range and increment the column number each monday or change of month. Store the column numbers in an array and use it as a lookup to determine the column number for a given date. Run this is a new clean workbook.
update - complete rewrite
Option Explicit
Const START_COL = 4
Const START_ROW = 22
Const MAX_YEARS = 4
Const START_YEAR = 2022
Sub CalendarDemo()
Dim ws As Worksheet
Dim dt As Date, dtDay1 As Date
Dim wkno As Long, dayno As Long
Dim colno As Long, i As Long, c As Long, r As Long
Dim arCol, arDate
ReDim arCol(1 To 2, 1 To MAX_YEARS * 12 * 7)
ReDim arDate(1 To MAX_YEARS * 366, 1 To 5) ' wkno, month no, column, date, dow
' start Jan 1
dtDay1 = DateSerial(START_YEAR, 1, 1)
colno = 1
wkno = 1
i = 1
' iterate through days built look up array
dt = dtDay1
Do While Year(dt) < START_YEAR + MAX_YEARS
arDate(i, 2) = Month(dt)
arDate(i, 5) = Weekday(dt, vbMonday)
If i > 1 Then
' change of week or month
If arDate(i, 5) = 1 Then
wkno = wkno + 1
If (wkno > 52) And (Month(dt) = 1) Then wkno = 1
colno = colno + 1
ElseIf arDate(i, 2) <> arDate(i - 1, 2) Then
colno = colno + 1
End If
End If
' reset wkno to 1 on jan 1st
If wkno >= 52 And arDate(i, 2) = 1 Then wkno = 1
arDate(i, 1) = wkno
arDate(i, 3) = colno
arDate(i, 4) = dt
' fill arCol
arCol(1, colno) = Format(dt, "mmm yyyy")
arCol(2, colno) = wkno
dt = dt + 1
i = i + 1
Loop
' paint cells
Dim lastrow As Long, dtStart As Date, dtEnd As Date
Dim colStart As Long, colEnd As Long, n As Long, m As Long
Set ws = Sheets(1)
Call testdata(ws)
With ws
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
For r = START_ROW To lastrow
' check dates are valid
dtStart = .Cells(r, "B")
dtEnd = .Cells(r, "C")
If dtEnd < dtStart Then
MsgBox "End Date before Start Date on row " & r, vbCritical
Exit Sub
ElseIf dtStart < dtDay1 Then
MsgBox "Start Date before 1 Jan " & START_YEAR & " on row " & r, vbCritical
Exit Sub
End If
' calc day number relative to day1
m = DateDiff("d", dtDay1, dtStart, dtDay1) + 1
n = DateDiff("d", dtDay1, dtEnd, dtDay1) + 1
If n > UBound(arDate) Or m > UBound(arDate) Then
MsgBox "Increase MAX_YEARS for row " & r, vbCritical
Exit Sub
End If
' lookup col number
colStart = arDate(m, 3) + START_COL
colEnd = arDate(n, 3) + START_COL
' merge and color
With .Cells(r, colStart)
With .Resize(1, colEnd - colStart + 1)
.Interior.Color = vbYellow
.Borders.LineStyle = xlContinuous
.Merge
End With
.Value = Space(5) & Format(dtStart, "dd mmm") & " - " & Format(dtEnd, "dd mmm yyyy")
End With
Next
End With
' add headers
Call FormatSheet(ws, arCol, arDate, colno)
MsgBox "Generated " & colno & " Columns", vbInformation
End Sub
Sub FormatSheet(ws As Worksheet, arCol, arDate, colno As Long)
Dim c As Long, i As Long, n As Long, dt As Date
' format sheet header rows
With Sheet1
.Rows("10:21").Clear
.Cells.MergeCells = False
With .Range("E20").Resize(2, colno)
.NumberFormat = "#"
.HorizontalAlignment = xlCenter
.Value2 = arCol
End With
' merge months
i = 0
For c = 5 To colno + 4
If .Cells(20, c + 1) = .Cells(20, c) Then
i = i + 1
Else
With .Cells(20, c - i)
Application.DisplayAlerts = False
.Resize(1, i + 1).Merge
Application.DisplayAlerts = True
.Resize(2, 1).Borders(xlLeft).LineStyle = xlContinuous
End With
i = 0
End If
Next
End With
' calendar to check array
For i = 1 To UBound(arDate)
dt = arDate(i, 4) ' date
n = arDate(i, 5) ' weekday
If dt > 0 Then
n = Weekday(dt, vbMonday)
ws.Cells(10 + n, arDate(i, 3) + START_COL) = Day(dt)
End If
' mon,tue,wed
If i < 8 Then
ws.Cells(10 + n, START_COL) = WeekdayName(n)
End If
Next
End Sub
Sub testdata(ws)
With ws
.Cells(22, 2) = "2022-01-01": .Cells(22, 3) = "2022-03-08"
.Cells(23, 2) = "2022-02-01": .Cells(23, 3) = "2022-02-28"
.Cells(24, 2) = "2022-03-01": .Cells(24, 3) = "2022-03-31"
.Cells(25, 2) = "2022-03-15": .Cells(25, 3) = "2022-05-15"
.Cells(26, 2) = "2022-03-15": .Cells(26, 3) = "2024-03-20"
End With
End Sub
I have a problem with displaying multiple columns in a ListBox in my UserForm.
Everything is working until my numbers of column is max 10.
My code:
Private Sub FindButton_Click()
ListBoxResult.Clear
ListBoxResult.ColumnCount = 14
Dim RowNum As Long
RowNum = 1
Do Until Sheets("db").Cells(RowNum, 1).Value = ""
If InStr(1, Sheets("db").Cells(RowNum, 2).Value, FindDMC.Value, vbTextCompare) > 0 Then
On Error GoTo next1
ListBoxResult.AddItem Sheets("db").Cells(RowNum, 1).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 2) = Sheets("db").Cells(RowNum, 2).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 3) = Sheets("db").Cells(RowNum, 3).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 4) = Sheets("db").Cells(RowNum, 4).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 5) = Sheets("db").Cells(RowNum, 5).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 6) = Sheets("db").Cells(RowNum, 6).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 7) = Sheets("db").Cells(RowNum, 7).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 8) = Sheets("db").Cells(RowNum, 8).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 9) = Sheets("db").Cells(RowNum, 9).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 10) = Sheets("db").Cells(RowNum, 10).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 11) = Sheets("db").Cells(RowNum, 11).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 12) = Sheets("db").Cells(RowNum, 12).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 13) = Sheets("db").Cells(RowNum, 13).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 14) = Sheets("db").Cells(RowNum, 14).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 15) = Sheets("db").Cells(RowNum, 15).Value
End If
next1:
RowNum = RowNum + 1
Loop
End Sub
ListBoxResult.ColumnCount and properties is 14, also Column widths is ok.
After runing my code the failure code is Run-time error '380': Could not set the List property. Invalid property value. At first, I was thinking that maybe ListBoxes have limits for columns, but I found ListBoxes with 60 columns on the Internet.
I am trying also this, but still doesn't work:
Private Sub Browser_RMA_Initialize()
ListBoxResult.RowSource = "db!a1:z1"
ListBoxResult.ColumnCount = 14
ListBoxResult.ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;"
ListBoxResult.ColumnHeads = True
End Sub
Could you support me, please?
Assigning to .Columnproperty avoids transposing
As late addition to #Dy.Lee 's valid and already accepted array approach (see my comment), I demonstrate a way how to avoid both repeated redimming [4] and transposing [5]:
Option Explicit ' declaration head of UserForm code module
Private Sub FindButton_Click()
'[0] where to search
Const SearchCol As Long = 2 ' get search items from 2nd column
'[1] define data set
Dim data As Variant
data = Tabelle1.Range("A1").CurrentRegion ' << change to your project's sheet Code(Name)
Dim ii As Long: ii = UBound(data, 1) ' row count
Dim jj As Long: jj = UBound(data, 2) ' column count
'[2] provide for sufficient result rows (array with converted row : columns order)
Dim results() As Variant
ReDim Preserve results(1 To jj, 1 To ii) ' redim up to maximum row count ii
'[3] assign filtered data
Dim i As Long, j As Integer, n As Long
For i = 1 To ii
If InStr(1, data(i, SearchCol), FindDMC.Value, vbTextCompare) > 0 Then
'' If data(i, SearchCol) = FindDMC.Value Then ' exact findings
n = n + 1
For j = 1 To jj
results(j, n) = data(i, j)
Next
End If
Next i
'[4] fill listbox with results
With ListBoxResult
.Clear
.ColumnCount = 14
.ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;"
If n Then
'[4] redimension only a 2nd time (& last time)
ReDim Preserve results(1 To jj, 1 To n)
'[5] assign results to listbox'es .Column property
.Column = results ' << .Column property avoids unnecessary transposing
End If
End With
End Sub
The column index of the listbox also starts at 0. The index number of additem should be 0, and you specified 15 at the end, then the number of columns becomes 16, so an error occurs because column 14 is exceeded.
It would be convenient to use an array.
Private Sub FindButton_Click()
Dim Ws As Worksheet
Dim vDB As Variant, vResult()
Dim i As Long, j As Integer, n As Long
Set Ws = Sheets("db")
vDB = Ws.Range("a1").CurrentRegion
For i = 1 To UBound(vDB, 1)
If InStr(1, vDB(i, 2), FindDMC.Value, vbTextCompare) > 0 Then
n = n + 1
ReDim Preserve vResult(1 To 14, 1 To n)
For j = 1 To 14
vResult(j, n) = vDB(i, j)
Next
End If
Next i
With ListBoxResult
.Clear
.ColumnCount = 14
.ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;"
If n Then
If n = 1 Then
.Column = vResult
Else
.List = WorksheetFunction.Transpose(vResult)
End If
End If
End With
End Sub
I am trying to fill a series from a higher number in cell G2 (e.g "512") down to a lower number in Cell H2 (e.g "500"). I need the VBA code to run in Column J, producing the following this series as an example 512, 511, 510, 509, 508 ... down the column.
Here's a screenshot that describes what I need
Most examples I've found seems to be built for an increasing series (512, 513, 514....)
Any help to get this right will be helpful
For a VBA general solution, try this
Sub CreateSequence(StartValue As Long, EndValue As Long, OutputStart As Range, Optional ByVal StepBy As Long = 1)
Dim NumValues As Long
Dim dat As Variant
Dim i As Long
StepBy = Abs(StepBy)
If StepBy <= 0 Then Exit Sub
NumValues = Abs(StartValue - EndValue) \ StepBy + 1
ReDim dat(1 To NumValues, 1 To 1)
For i = 0 To NumValues - 1
dat(i + 1, 1) = StartValue + i * IIf(StartValue > EndValue, -StepBy, StepBy)
Next
OutputStart.Resize(UBound(dat, 1), 1).Value = dat
End Sub
Use it like this
Sub Demo()
CreateSequence Range("G2").Value, Range("H2").Value, Range("K2")
End Sub
A formula solution (Excel version 365)
=SEQUENCE(G2-H2+1,1,G2,-1)
hlRange = Sheets(2).Cells(2, 7).Value - Sheets(2).Cells(2, 8).Value + 1
' Fill series from max to min value
For j = 1 To hlRange
Sheets(2).Cells(j + 1, 10).Value = Sheets(2).Cells(2, 7).Value - j + 1
Next j
You can use the following code, it lets you add a a values to specify the steps you want to have.
https://i.stack.imgur.com/vSan5.jpg
Sub createNumList()
Dim i As Integer
Dim count As Integer
Dim cellValue As Integer
count = (ActiveSheet.Cells(2, 1).Value - ActiveSheet.Cells(2, 2).Value) / ActiveSheet.Cells(2, 3).Value
For i = 1 To count + 1
If i = 1 Then
ActiveSheet.Cells(i + 2, 5).Value = ActiveSheet.Cells(2, 1).Value
Else
ActiveSheet.Cells(i + 2, 5).Value = ActiveSheet.Cells(i + 1, 5).Value - ActiveSheet.Cells(2, 3).Value
End If
Next i
End Sub
I tried to write the followings to transfer the data from one workbook to another one, however, it gets the error 9 that is out of script range. I've checked twice and could not locate any mistakes. Could you help to check to see whether I have missed anything or something is wrong? Thanks a lot.
Private Sub Transfer_Click()
Application.ScreenUpdating = False
Sheets("List").Select
v = Range("A2").End(xlDown).Row
Dim a()
Dim b()
ReDim a(v - 1)
ReDim b(v - 1)
Sheets("Yahoo").Select
For i = 0 To v - 1
a(i) = Cells(i + 7, 4)
b(i) = Cells(i + 7, 5)
Next
ChDir "C:\Users\Desktop\Data Analysis"
Workbooks.Open Filename:="C:\Users\Desktop\Data Analysis\Data.xlsx"
Sheets("List").Select
For i = 2 To Range("A1").End(xlDown).Row
Sheets("List").Select
k = Cells(i, 1)
If k = "" Then Exit For
Sheets(k).Select
h = Range("B8").End(xlDown).Row
Cells(h + 1, "B") = a(i - 2)
Cells(h + 1, "F") = b(i - 2)
Next
Windows("Data.xlsm").Activate
Sheets("Yahoo").Select
Application.CutCopyMode = False
Workbooks("Data.xlsx").Save
Workbooks("Data.xlsx").Close
Application.ScreenUpdating = True
MsgBox "Successfully transferred!", vb0XOnly, "Notice"
End Sub