I have an issue that, multi dimensional array which is trying to put the ID's for group member combinations from calendar hierarchy (Year -> super_Season -> Quarter -> month -> week). problem is one of the Week's ID number to be changed when it comes to the particular week. Say for example as per the screenshot if this week comes the ID/index should get increased by 1
Entry which needs to change the ID
The code which i have to modify for this issue is as below
Public Function writeStructure(intdimension As Integer) As Boolean
Dim objGroup As Variant
Dim objMember As Variant
Dim strError As String
Dim i As Integer
Dim j As Integer
On Error GoTo ErrorRoutine
writeStructure = False
'write structure
strError = "writing structure to " & readIniFileString("Dimensions", "Name" & intdimension, strControlFileIni)
With Worksheets(readIniFileString("Dimensions", "Name" & intdimension, strControlFileIni))
.Cells.Clear
i = 1
For Each objGroup In objGroups.Items
.Cells(i, 1).Value = objGroup.Number
.Cells(i, 2).Value = objGroup.Name
i = i + 1
Next
i = 1
For Each objMember In objMembers.Items
.Cells(i, 3).Value = objMember.Number
.Cells(i, 4).Value = objMember.Name
.Cells(i, 5).Value = objMember.Description
.Cells(i, 6).Value = objMember.Group
.Cells(i, 7).Value = objMember.groupName
For j = 1 To objMember.countOfParents
.Cells(i, 7 + j).Value = objMember.Parent(j) ' ID values are assigning
Next j
i = i + 1
Next
End With
Related
Im trying to change values in a dictionary dynamically. If value exists in dictionary, change that value to dictionary value + new value (incremental).
Im unable to do this however, i get the Run-time error 451: Property let procedure not defined and property get procedure did not return an object. Can someone help me do a "sumifs" -type of changes to the dictionary?
Sub Sumifs()
Dim objDictionary
Set objDictionary = CreateObject("Scripting.Dictionary")
Dim arr As Variant
Dim lr1 As Long
Dim arr2 As Variant
Dim lr2 As Long
With Blad15
lr1 = Worksheets("Sheet1").Cells(.Rows.Count, 5).End(xlUp).Row
arr = Worksheets("Sheet1").Range("E20:E" & lr1)
Debug.Print UBound(arr)
Debug.Print lr1
End With
ThisWorkbook.Sheets("Sheet1").Select
For i = 1 To UBound(arr)
objDictionary.Add Key:=CStr(Cells(i + 19, 5)), Item:=CStr(Cells(i + 19, 5))
Next
ThisWorkbook.Sheets("Sheet2").Select
With Blad6
lr2 = Worksheets("Sheet2").Cells(.Rows.Count, 2).End(xlUp).Row
arr2 = Worksheets("Sheet2").Range("B2:B" & lr2 + 1)
End With
For i = 1 To UBound(arr)
If objDictionary.Exists(Cells(i + 1, 2).Value) Then
objDictionary(Cells(i + 1, 2).Value) = objDictionary.Items(Cells(i + 1, 2)) + Worksheets("Sheet2").Cells(i + 1, 8).Value 'Error occurs here
End If
Next
End Sub
Based on your comments and the screenshots I understood it like that:
I created a new class module customer with the code below
Option Explicit
Public customerName As String
Public invoiceAmount As Double
Public cashReceived As Double
and then I created a new module with the following code for creating the summary
Sub CreateSummary()
Dim dict As Dictionary
Dim rgInvoices As Range
Set rgInvoices = Worksheets("Invoices sent").Range("A1").CurrentRegion
Set rgInvoices = rgInvoices.Offset(1).Resize(rgInvoices.Rows.Count - 1)
Dim sngRow As Range
Dim oneCustomer As customer
Set dict = New Dictionary
Dim customerName As String
Dim amount As Double
' Sum up the invoice amount for each single customer
For Each sngRow In rgInvoices.Rows
customerName = sngRow.Cells(1, 1).Value
amount = sngRow.Cells(1, 3).Value
If dict.Exists(sngRow.Cells(1, 1).Value) Then
dict(customerName).invoiceAmount = dict(customerName).invoiceAmount + amount
Else
Set oneCustomer = New customer
With oneCustomer
.customerName = customerName
.invoiceAmount = amount
End With
dict.Add oneCustomer.customerName, oneCustomer
End If
Next sngRow
Dim rgCashReceived As Range
Set rgCashReceived = Worksheets("Cash received").Range("A1").CurrentRegion
Set rgCashReceived = rgCashReceived.Offset(1).Resize(rgCashReceived.Rows.Count - 1)
' Sum up the cash received for each single customer
For Each sngRow In rgCashReceived.Rows
customerName = sngRow.Cells(1, 1).Value
amount = sngRow.Cells(1, 3).Value
If dict.Exists(sngRow.Cells(1, 1).Value) Then
dict(customerName).cashReceived = dict(customerName).cashReceived + amount
Else
Set oneCustomer = New customer
With oneCustomer
.customerName = customerName
.cashReceived = amount
End With
dict.Add oneCustomer.customerName, oneCustomer
End If
Next sngRow
' Print Out
Dim vKey As Variant
Dim i As Long
Dim shOut As Worksheet
Set shOut = Worksheets("Summary")
' Heading
With shOut
.Cells(1, 1).CurrentRegion.Clear
.Cells(1, 1).Value = "Customer Name"
.Cells(1, 2).Value = "Invocie amount"
.Cells(1, 3).Value = "Cash received"
' single rows
i = 2
For Each vKey In dict.Keys
Debug.Print vKey, dict(vKey).invoiceAmount, dict(vKey).cashReceived
.Cells(i, 1).Value = vKey
.Cells(i, 2).Value = dict(vKey).invoiceAmount
.Cells(i, 3).Value = dict(vKey).cashReceived
i = i + 1
Next vKey
End With
End Sub
Resolution for Compile error: User defined type not defined underlining Dim dict As dictionary Select Tools->Reference from the Visual Basic menu. Place a check in the box beside “Microsoft Scripting Runtime”
Though question remains: Why don't you use excel's built in SUMIF?
You can also try the second example from Macromastery
I want sheets "Status" and "Ref" compared. If the values match in both columns Status!F and Ref!B AND Status!Q and Ref!C for a particular individual's data in a row, then copy the value from Ref!F to Status!H
This is my first ever attempt at writing code so it's probably full of errors, but the debugger points out the first If statement in particular. I've tried it with and without parentheses.
Sub help()
Dim i As Long
Dim j As Long
Dim index As Integer
Sheet1LastRow = Worksheets("Status").Range("F" & Rows.Count).End(xlUp).Row
Sheet2LastRow = Worksheets("Ref").Range("B" & Rows.Count).End(xlUp).Row
For index = 1 To Sheet1LastRow
If ((Worksheets("Status").Cells(i, 6).Value = Worksheets("Ref").Cells(j, 2).Value) And (Worksheets("Status").Cells(i, 17).Value = Worksheets("Ref").Cells(j, 3).Value)) Then Worksheets("Status").Cells(i, 8).Value = Worksheets("Ref").Cells(j, 6)
Next
index = index + 1
j = j + 1
i = i + 1
Do Until index = Sheet1LastRow
Loop
End Sub
edit - a note--these sheets are not in the same order. so row 1500 in Status could match something on row 3 on ref, for example
Try this
For i = 1 To Sheet1LastRow
For j = 1 To Sheet2LastRow
If ((Worksheets("Status").Cells(i, 6).Value = Worksheets("Ref").Cells(j, 2).Value) and (Worksheets("Status").Cells(i, 17).Value = Worksheets("Ref").Cells(j, 3).Value)) Then
Worksheets("Status").Cells(i, 8).Value = Worksheets("Ref").Cells(j, 6).Value
Exit for
End if
Next j
Next i
Image1
Hi, Referring to the image, I am trying to compare column G and Column K, if the value is the same then copy the value in column J to column F. However, my code doesn't copy the value from Column J to F.
Sub createarray1()
Dim i As Integer
Dim j As Integer
Dim masterarray As Range
Set masterarray = Range("D3:G12")
Dim sourcearray As Range
Set sourcearray = Range("H3:K26")
For i = 1 To 10
For j = 1 To 25
If masterarray(i, 4).Value = sourcearray(j, 4).Value Then
masterarray(i, 3) = sourcearray(j, 3).Value
Else
masterarray(i, 3).Value = ""
End If
Next
Next
End Sub
Function concatenate()
Dim nlastrow As Long
For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
Cells(i, "G").Value = Cells(i, "D").Value & "_" & Cells(i, "E").Value
Next i
Dim nnlastrow As Long
For i = 2 To Cells(Rows.Count, "H").End(xlUp).Row
Cells(i, "K").Value = Cells(i, "H").Value & "_" & Cells(i, "I").Value
Next i
End Function
Use variant arrays, that way you limit the number of calls to the sheet to only 3.
When your positive is found you need to exit the inner loop.
Sub createarray1()
Dim i As Long
Dim j As Long
Dim masterarray As Variant
Dim sourcearray As Variant
With ThisWorkbook.Worksheets("Sheet1") ' change to your sheet
masterarray = .Range("D3:G12")
sourcearray = .Range("H3:K26")
For i = LBound(masterarray, 1) To UBound(masterarray, 1)
masterarray(i, 3) = ""
For j = LBound(sourcearray, 1) To UBound(sourcearray, 1)
If masterarray(i, 4) = sourcearray(j, 4) Then
masterarray(i, 3) = sourcearray(j, 3)
Exit For
End If
Next j
Next i
.Range("D3:G12") = masterarray
End With
End Sub
But this can all be done with the following formula:
=INDEX(J:J,MATCH(G3,K:K,0))
Put it in F3 and copy/drag down.
I'm writing a VBA program.
I have a problem with finding this string [BLOCKED] in one column
For j = 0 To 4
For i = 2 To lastrow
If Cells(i, 12).Value = groupnames(j) And Cells(i, 8).Value Like "*" & "[BLOCKED]" & "*" Then
groupsum(j) = groupsum(j) + 1
End If
Next i
Next j
The problem is I have 96 cells for this string but the program found 500 how can I do this to going work?
Thanks for help
The syntax of your Like operation is incorrect. Use:
... Like "*[[]BLOCKED]*"
[...] is a Character class. So, the way you have it written in your question, it will find any single character in the set of BLOCKED. That is not what you want, apparently.
To match the [ character, you enclose it within a character class, as I have shown. To match the ] character, it must be outside of a character class.
here is my code
Sub blocked()
Dim SfileUsers As String
Dim path As String
Dim pathread As String
Dim sFileread As String
Dim lastrow As Long
Dim keres() As Variant
Dim groupadd() As String
Dim groupnames(4) As String
Dim groupsum(4) As Long
path = "C:\Users\uids9282\Desktop\"
SfileUsers = "Users.xlsx"
Workbooks.Open path & SfileUsers
Dim hossz As Long
hossz = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim keres(hossz)
ReDim groupadd(hossz)
For i = 2 To hossz
keres(i) = Sheets(1).Cells(i, 2).Value
groupadd(i) = Sheets(1).Cells(i, 4).Value
Next i
'fájlmegnyitás
pathread = "C:\Users\uids9282\Desktop\20170703\"
sFileread = "open.xml"
If Dir(pathread & sFileread) = sFileread Then
Workbooks.Open pathread & sFileread
lastrow = Workbooks(sFileread).Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Else
MsgBox ("Nincs ilyen nevű excel táblázat. Kérem próbálkozzon újra")
End If
'groupok hozzáadása a fájlhoz
Dim user As String
For j = 2 To hossz
For i = 2 To lastrow
user = Trim(Cells(i, 5).Value)
If user = keres(j) Then
Cells(i, 12).Value = groupadd(j)
End If
Next i
Next j
'group szummázása és átírása
ThisWorkbook.Activate
For i = 2 To 6
groupnames(i - 2) = Cells(i, 1).Value
Next i
Workbooks(sFileread).Activate
For j = 0 To 4
For i = 2 To lastrow
If Cells(i, 12).Value = groupnames(j) And Cells(i, 8).Value Like "*[[]BLOCKED[]]*" Then 'itt van benne a hiba!! groupsum(j) = groupsum(j) + 1
End If
Next i
Next j
ThisWorkbook.Activate
For j = 2 To 6
Cells(j, 4).Value = groupsum(j - 2)
Next j
Workbooks(SfileUsers).Close SaveChanges:=False
Workbooks(sFileread).Close SaveChanges:=True
End Sub
this is my excel file where i want to searching
I was running a VBA code in Excel 2007. I got the above mention run/Application error of 1004.
My code is
Public Sub LblImport_Click()
Dim i As Long, j As Long
Dim vData As Variant, vCleanData As Variant, vFile As Variant, sMarket As String
Dim wbkExtract As Workbook, sLastCellAddress As String, month As String
Dim cnCountries As New Collection
Application.ScreenUpdating = False
' Get the name of the Dataview Extract file to transform and the market name
vFile = "D:\DRX\" & "Norvasc_Formatted.xlsx"
sMarket = "Hypertension"
ThisWorkbook.Worksheets("Control").Range("TherapeuticMarket").Value = "Hypertension"
' Clear all existing data from this workbook
ThisWorkbook.Worksheets("RawData").Cells.ClearContents
' Create labels in Raw Data Sheet
ThisWorkbook.Worksheets("RawData").Cells(1, 1).Value = "Therapy Market"
ThisWorkbook.Worksheets("RawData").Cells(1, 2).Value = "Country"
ThisWorkbook.Worksheets("RawData").Cells(1, 3).Value = "Brand"
ThisWorkbook.Worksheets("RawData").Cells(1, 4).Value = "Corporation"
ThisWorkbook.Worksheets("RawData").Cells(1, 5).Value = "Molecule"
' Open Dataview extract, copy and clean data
Set wbkExtract = Workbooks.Open(vFile)
i = 2
Do While wbkExtract.ActiveSheet.Cells(1, i).Value <> ""
If UCase(Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 3)) = "TRX" Then
month = Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(1)
If Len(month) = 1 Then
month = "0" + month
End If
ThisWorkbook.Worksheets("RawData").Cells(1, i + 4).Value = Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 10) + month + "/" + Mid(Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(2), 3, 2)
End If
If UCase(Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 3)) = "LCD" Then
month = Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(2)
If Len(month) = 1 Then
month = "0" + month
End If
ThisWorkbook.Worksheets("RawData").Cells(1, i + 4).Value = Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 14) + month + "/" + Mid(Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(3), 3, 2)
End If
i = i + 1
Loop
wbkExtract.ActiveSheet.Cells(1, 1).EntireRow.Delete
vData = wbkExtract.ActiveSheet.Cells(1, 1).CurrentRegion.Value
wbkExtract.Close savechanges:=False
vCleanData = CleanRawData(vData, sMarket)
sLastCellAddress = ThisWorkbook.Worksheets("RawData").Cells(UBound(vCleanData, 1) + 1, UBound(vCleanData, 2)).Address(RowAbsolute:=False, ColumnAbsolute:=False)
ThisWorkbook.Worksheets("RawData").Range("A2:" & sLastCellAddress).Value = vCleanData
' Get List of Unique Countries
On Error Resume Next
For i = 1 To UBound(vCleanData, 1)
cnCountries.Add vCleanData(i, 2), vCleanData(i, 2)
Next i
On Error GoTo 0
ThisWorkbook.Worksheets("Market").Cells(1, 1).CurrentRegion.Clear
ThisWorkbook.Worksheets("Market").Cells(1, 1).Value = "Country"
ThisWorkbook.Worksheets("Market").Cells(1, 2).Value = "Group 1"
ThisWorkbook.Worksheets("Market").Cells(1, 3).Value = "Group 2"
ThisWorkbook.Worksheets("Market").Cells(1, 4).Value = "Group 3"
ThisWorkbook.Worksheets("Market").Cells(1, 5).Value = "Group 4"
ThisWorkbook.Worksheets("Market").Range("A1:G1").Font.Bold = True
For i = 1 To cnCountries.Count
ThisWorkbook.Worksheets("Market").Cells(i + 1, 1).Value = cnCountries.Item(i)
Next i
End Sub
Sounds like a broken code cache.
I've seen errors happen like this before in older format (xls) workbooks and it can be a sign of problems in the file overall.
Try the compile option suggested by #Scott Holtzman first. In some cases I've seen the recompile not work and if that happens just force a compile by making a change to the code. A trivial change is enough usually.
If that doesn't work then (to help disagnose a corruption issue) try copying the code into a new workbook and see what happens there. If it runs in the new sheet then I wouldn't waste more time on it and just rebuild the sheet, trust me it'll be quicker than messing about troublshooting the one you have.