The basic idea of this (from the array names) are timesheets.
I have a Master Time sheet that has everyones' name on it, + the days.
The Concept is, open the http link from L/UBounds of array. Grab the data from the specific sheet, put it in my master sheet, close out that workbook, move on to next name.
Sub PassToProc()
Dim arr(4) As String
arr(0) = "https://sharepoint/Time Sheets/Jeff.xlsm"
arr(1) = "https://sharepoint/Time Sheets/Jonathan.xlsm"
arr(2) = "https://sharepoint/Time Sheets/Jim.xlsm"
arr(3) = "https://sharepoint/Time Sheets/Topher.xlsm"
arr(4) = "https://sharepoint/Time Sheets/Brandon.xlsm"
' Pass the array to function
UseArray arr
End Sub
Function UseArray(ByRef arrs() As String)
Dim name As String
Dim i As Integer
For i = LBound(arrs) To UBound(arrs)
If Cells(3, i + 4) <> "" Then
name = Cells(3, i + 4)
Select Case name
Case "Jeff"
Call InfoPuller(arrs, 0)
Case "Jonathan"
Call InfoPuller(arrs, 1)
Case "Jim"
Call InfoPuller(arrs, 2)
Case "Topher"
Call InfoPuller(arrs, 3)
Case "Brandon"
Call InfoPuller(arrs, 4)
End Select
End If
Next i
End Function
Sub InfoPuller(ByRef link() As String, i As Integer)
Dim Pay1 As String, Pay2 As String, PayPeriod As String
Dim wkb As Workbook
Pay1 = Format(Cells(3, 2), "m-dd")
Pay2 = Format(Cells(24, 1), "m-dd")
PayPeriod = "" & Pay1 & " -- " & Pay2 & ""
'Jeff (x,4) i = 0
'Jon (x,5) i = 1
'Jim (x,6) i = 2
'Topher (x,7) i = 3
'Brandon (x,8) i = 4
Set wkb = Workbooks.Open(link(i))
' Pay period 1 Fill in
For j = 5 To 11
ThisWorkbook.Sheets(PayPeriod).Cells(j, i + 4) = Workbooks.Open(link(i)).Worksheets(PayPeriod).Cells(j + 4, 9).Value
Next j
' Mileage / Bridge Week 1
Dim Mileage As Integer, Bridge As Integer, Store As Integer, Store2 As Integer
Dim MandB As String
Mileage = Workbooks.Open(link(i)).Worksheets(PayPeriod).Cells(28, 3).Value
Bridge = Workbooks.Open(link(i)).Worksheets(PayPeriod).Cells(29, 3).Value
MandB = Mileage & " / " & Bridge
ThisWorkbook.Sheets(PayPeriod).Cells(13, i + 4) = MandB
Store = Mileage
Store2 = Bridge
'Pay Period 2 Fill in
For j = 18 To 24
ThisWorkbook.Sheets(PayPeriod).Cells(j, i + 4) = Workbooks.Open(link(i)).Worksheets(PayPeriod).Cells(j + 1, 9).Value
Next j
' Mileage / Bridge Week 2
Mileage = Workbooks.Open(link(i)).Worksheets(PayPeriod).Cells(28, 4).Value
Bridge = Workbooks.Open(link(i)).Worksheets(PayPeriod).Cells(29, 4).Value
MandB = Mileage & " / " & Bridge
ThisWorkbook.Sheets(PayPeriod).Cells(26, i + 4) = MandB
Store = Store + Mileage
Store2 = Store2 + Bridge
MandB = Store & " / " & Store2
ThisWorkbook.Sheets(PayPeriod).Cells(31, i + 4) = MandB
wkb.Close SaveChanges:=True
End Sub
The problem is on this snippet.
For j = 5 To 11
ThisWorkbook.Sheets(PayPeriod).Cells(j, i + 4) = Workbooks.Open(link(i)).Worksheets(PayPeriod).Cells(j + 4, 9).Value
Next j
ThisWorkbook refers to the MasterSheet that the macro is running off of. PayPeriod is determined by the dates. Workbooks.Open(link(i)... is because if I try Workbooks(link(i)), it didn't like it (but it only opens up 1 copy, so I'm not worried about repeats).
As soon as it executes the Thisworkbook.sheets(PayPeriod), I hit the RTE-9 Subscript Out of Range error. The cells lines up, my pull data is right. I shortened the https link to just Sharepoint for privacy.
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'm trying to copy rows from one sheet to another if they have dates that match. I've used this method before and it worked fine. I can't work out where I'm going wrong here for the life of me.
Public Sub dayreport()
Dim enteredday As Variant
Dim clockinday As Variant
Dim y As Integer
Dim yreport As Integer
Dim yrow As Integer
Dim daystring As String
Dim datecheck As Boolean
'Collect the entered date
enteredday = CVar(Sheets("Process").Cells(3, 3)) 'get the datestring out of the date cell
'Only progress if a date is entered
If IsDate(enteredday) = True Then
datecheck = True 'a usable date has been entered
Else
datecheck = False
MsgBox "Entered date must be a real date of the format dd/mm/yyyy"
End If
If datecheck = True Then
'Delete the day report if it already exists
Call Delete_Sheet("Day Report")
'create a new sheet
Worksheets.Add.name = "Day Report"
y = 7
yreport = 7
yrow = 7
'While there is data in any of the cells of the investigated row, loop
Do While Sheets("Process").Cells(y, 1) <> "" _
Or Sheets("Process").Cells(y, 2) <> "" _
Or Sheets("Process").Cells(y, 3) <> "" _
Or Sheets("Process").Cells(y, 4) <> "" _
Or Sheets("Process").Cells(y, 5) <> "" _
Or Sheets("Process").Cells(y, 6) <> "" _
Or Sheets("Process").Cells(y, 7) <> "" _
Or Sheets("Process").Cells(y, 8) <> "" _
'breakdown entered date
year = CInt(Right(enteredday, 4)) 'take the year component from the date and convert it to an integer
month = CInt(Mid(enteredday, 4, 2)) 'take the month component from the date and convert it to an integer
day = CInt(Left(enteredday, 2)) 'take the day component from the date and convert it to an integer
enteredday = DateSerial(year, month, day)
'Breakdown investigated date
clockinday = CVar(Sheets("Process").Cells(y, 2)) 'get the datestring out of the date cell
sheetyear = CInt(Right(clockinday, 4))
sheetmonth = CInt(Mid(clockinday, 4, 2))
sheetday = CInt(Left(clockinday, 2))
clockinday = DateSerial(sheetyear, sheetmonth, sheetday)
'copy the row pairs into the day report sheet if the entered date matches the date in the row
If enteredday = clockinday Then
For i = 1 To 9
Sheets(“Day Report”).Cells(yreport, i) = Sheets(“Process”).Cells(y, i)
Sheets(“Day Report”).Cells(yreport + 1, i) = Sheets(“Process”).Cells(y + 1, i)
yreport = yreport + 2
Next i
End If
yrow = yrow + 2
y = y + 2
Loop
End If
End Sub
Instead of the for-loop copying dates, I also tried,
Worksheets("Process").Range(CVar("A" & yrow & ":" & "I" & yrow + 1)).Copy Worksheets(“Day Report”).Range(CVar("A" & yreport & ":" & "I" & yreport + 1))
It seems as though it is not able to see my Process sheet, yet it was populated by another sub which runs perfectly
this question is probably easy to solve but I cannot figure out how to do it and a quick web search didn't lead to anything. So here is my code:
Option Explicit
'Description: This macro is used to number plot all specimens into the stress-strain curve since this has become a task that
'has to be done very frequently
Sub PlotAllSpecimens_Tensile()
Dim ws As Worksheet, wb As Workbook
Dim xrng As Range, yrng As Range, namerng As Range
Dim CH As Chart, CHcond As Chart, CHdry As Chart
Dim Material As String, state As String, Temperatur As String, name As String
Dim i As Integer, j As Integer, idry As Integer, icond As Integer, k As Integer
Dim ser As series
Dim startrow As Integer
Set wb = ActiveWorkbook
idry = 1
icond = 1
For Each CH In wb.Charts
If CH.name = "Stress-Strain curve cond" Then
Set CHcond = CH
ElseIf CH.name = "Stress-Strain curve dry" Then
Set CHdry = CH
End If
Next CH
If Not CHdry Is Nothing Then
For Each ser In CHdry.SeriesCollection
ser.Delete
Next ser
End If
If Not CHcond Is Nothing Then
For Each ser In CHcond.SeriesCollection
ser.Delete
Next ser
End If
For Each ws In wb.Worksheets
If ws.name <> "Start" And ws.name <> "Auswertung" And ws.name <> "Zusammenfassung" Then
i = 1
For k = 1 To 15
If ws.Cells(k, 5 * i - 4) = "Material" Or ws.Cells(k, 5 * i - 4) = "Werkstoff" Then
Material = ws.Cells(k, 5 * i - 3).Value
ElseIf ws.Cells(k, 5 * i - 4) = "Temperatur" Then
Temperatur = ws.Cells(k, 5 * i - 3).Value
ElseIf ws.Cells(k, 5 * i - 4) = "Zustand" Then
state = ws.Cells(k, 5 * i - 3).Value
End If
Next k
While Not IsEmpty(ws.Cells(i * 5 - 4).Value)
name = Material & "_" & i & ", " & state & ", " & Temperatur
Set namerng = ws.Cells(1, 5 * i - 1).End(xlDown).Offset(-1, -1)
namerng.Value = name
startrow = ws.Cells(1, 5 * i - 1).End(xlDown).Row
Set xrng = Range(ws.Cells(startrow, 5 * i - 2), ws.Cells(startrow, 5 * i - 2).End(xlDown))
Set yrng = Range(ws.Cells(startrow, 5 * i - 1), ws.Cells(startrow, 5 * i - 1).End(xlDown))
If Not (CHdry Is Nothing) And state = "dry" Then
CHdry.SeriesCollection.NewSeries
CHdry.SeriesCollection(idry).XValues = xrng
CHdry.SeriesCollection(idry).Values = yrng
CHdry.SeriesCollection(idry).name = ??????????
CHdry.SeriesCollection(idry).Border.ColorIndex = 42 + ws.Index Mod 5
idry = idry + 1
End If
If Not (CHcond Is Nothing) And state = "conditioned" Then
CHcond.SeriesCollection.NewSeries
CHcond.SeriesCollection(icond).XValues = xrng
CHcond.SeriesCollection(icond).Values = yrng
CHcond.SeriesCollection(icond).Border.ColorIndex = 42 + ws.Index Mod 5
CHcond.SeriesCollection(icond).name = ???????
icond = icond + 1
End If
i = i + 1
Wend
End If
Next ws
End Sub
????? marks the issue. I want to name my series the value of the cell "namerng" so if i later change this cell the name in the plot will update. This can be done manually in excel by selecting a cell as the name range. If I use:
CHcond.SeriesCollection(icond).name = namerng.value
The results will be correct but do not change after I change the value of the namerng. So how to I reference the value of one cell as a series name using VBA?
I got it it is:
CHcond.SeriesCollection(icond).name = "='" & ws.name & "'!" & namerng.Address
Not very elegant but it works.
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
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.