I am running into an issue when running code to create a powerpoint table from Excel data. When I debug the code, I can see that the code is correctly pulling the data, but it is disappearing at the end of the function. My goal is for the code to loop through all rows of data starting at A6(header), check column F for dates that are older than a week from today, and then take that data and put it into a ppt table with 3 columns.
my code:
dim count, i, j, f as integer: count = 3
dim PPRow as integer: PPRow = 2
dim maxheight as integer: maxheight = 380
slideNo = 4
j=SlideNo
f=1
i = Application.WorksheetFunction.CountA(Sheets("Assignments").Range("A6:A20"))
if i >=1 then
Set PPApp = CreateObject("Powerpoint.Application")
Set PPPres = PPApp.AcitvePresentation
PPAp.ActiveWindow.View.Gotoslide SlideNo
Dim r as long
for r = 7 to 37
if cells(r,"F").value> (Date +7) then
PPPres.Slides(SlideNo).Shapes("tblNonGreenMetrics").Table.Cell(PPRow,1).Shape.TextFrame.Text = Cells(r,"F".offset(o,-5)
PPPres.Slides(SlideNo).Shapes("tblNonGreenMetrics").Table.Cell(PPRow,2).Shape.TextFrame.Text = Cells(r,"F".offset(o,0)
o= o+1
end if
next
end if
end function
thank you
Related
I have a a table of values, which list item ids by the amount of those items in different qualities, like so:
ID QB QC UI
006780 12 - 6
100780 48 15 8
And so on for a thousand rows. As part of a further wrangling effort, I wish to get the id's and move them elsewhere and position them under each other with 2 blank cells between them. This is the code I've come up with and please bear with me, I'm trying to lear:
Sub laatuJako()
Dim idRange As Range
Dim tyoWb As Workbook
Dim tyoWks As Worksheet
Dim idRivit As Integer
Dim idArray() As Variant
Set tyoWb = ThisWorkbook
Set tyoWks = tyoWb.Sheets("Pivots->Apu")
idRivit = tyoWks.Range("Q7").End(xlDown).Row
ReDim idArray(0)
Dim varCounter As Integer
varCounter = 0
This next loop is a way I could form the array, since it seemed to run into run-time error 9 in the next loop.
For i = 0 To idRivit - 1
tyoWks.Activate
idArray(i) = tyoWks.Range("Q" & 7 + i).Value
varCounter = varCounter + 1
ReDim Preserve idArray(varCounter)
Next i
Dim k As Integer
Dim j As Integer
k = 0
j = 0
Do While k < idRivit
tyoWks.Range("X" & 7 + j).Value = idArray(k)
j = j + 3
k = k + 1
Loop
End Sub
Now the code works, but it seems that (un)helpfully VBA changed the id attribute to a number and printed the ids with numbers in front of them, for example 006780 as 6780. This was not wanted and so I changed the array into a string array, but it made no difference. Now an array is not necessary here and I can just copy-paste them directly using a loop, but I want to understand how I can control something like this, since the issue will come up again in situations where an array would be preferable.
Apologies, if the question is poorly described, there is a first time for everything.
I am volunteering with an NGO, helping to create a SQL database for their weekly client attendance data. Data currently sits in an Excel spreadsheet.
I want to manipulate said spreadsheet to avoid having them change their process.
About this spreadsheet:
Each row represents a different client, while a range of 3 columns holds the following info (time in, time out, and units) for 5 days of the week. Right above the time in - units block, is the date of service that set of info pertains to (the dates are merged across that range normally, but I had to un-merge that). A screenshot is below for reference
What I need done:
I need to record each instance of every client's attendance on a separate row (in a different location - can be on the same sheet), matching the corresponding date of service, time in, time out, and units, to the name.
What I have tried:
I tried doing a For... Next loop with 3 counters for the 3 different ranges of info I need to look up, and declared the counters as ranges. I'm not sure if While... Wend is more appropriate here.
I also tried going the array way, but that's not coming together in my VBA.
I was also wondering if there is a datetime datatype that can be applied to Excel to eliminate having to match that additional range of values to the rest.
Side note: The greyed out cells on the sheet means the client isn't scheduled to attend on that day. So I need to include an If statement to skip cells that are blank.
The following code will do what you require, enough to get you started I hope - please note I have two sheets, Sheet1 (where data is stored) and Sheet2 (where data is moved to)
I have put the loops in where r = current row on sheet1, c = current column and then x is the counter for sheet2
r loop starts on row 3 and only goes to 5 for an example but you can find the last row and change the 5, or use a lastRow variable e.g. lastRow = .cells(.rows.count,1).end(xlup).row
This all assumes that the data is always in exactly the format shown in your screenshot. You can rearrange the output easily enough within the innermost IF and END IF chunk
Sub shift_me()
Dim r As Long
Dim c As Long
Dim x As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
x = 1
With ThisWorkbook.Worksheets("Sheet1")
For r = 3 To 5
For c = 3 To 15 Step 3
If Not .Cells(r, c).Value2 = "" And Not .Cells(r, c).Value2 = 0 Then
ws.Cells(x, 1).Value2 = .Cells(r, 1).Value2
ws.Cells(x, 2).Value2 = .Cells(r, 2).Value2
ws.Cells(x, 3).Value2 = .Cells(r, c).Value2
ws.Cells(x, 4).Value2 = .Cells(r, c + 1).Value2
ws.Cells(x, 5).Value2 = .Cells(r, c + 2).Value2
ws.Cells(x, 6).Value2 = .Cells(1, c).Value2
x = x + 1
End If
Next c
Next r
End With
End Sub
New to VBA and am trying to essentially lookup column headers in on sheet to another and if match copy data over...
I was told that I can store my headers in a string array then loop through and compare the headers to my array to see if they match.
ie: For each c In
Sheet1.Range("A1:BA1").offset(rownumber -1)
But I'm not sure what that means? How do I store my headers in a string array? Sorry if this is a super basic question. I have googled it and not found anything explaining how to do this or what it means.
My Project:
research data on sheet1. If there is an issue I want to click a button that will copy only the matching column data to a new row in a Specified sheet. From there the data will be reviewed and then another button to export the data to an MS SQL table.
ie:
Sheet1
A B C D E
ID CUR Region Amount Y/N
1 USD NA $54 Y
Sheet2
A B C D E
Region CUR Amount Type Misc
So if Column E = Y then copy all the relevant data in that row to a new sheet:
Sheet2 (output)
A B C D E
Region CUR Amount Type Misc
NA USD $54 Null Null
Sheet2 has columns not in Sheet1 and vice versa... Also the order of the columns are not the same in each sheet. The real sheets are huge with many columns and the row count will change everytime I refresh my data. I need this to loop until Col A in Sheet1 is null.
How do I store my headers in a string array?
A very practical way:
Dim hdlist As String
Dim sep As String
hdlist = "ID|CUR|Region|Amount|Y/N" ' Change this line
sep = "|"
Dim hdnames() As String
hdnames = Split(hdlist, sep, -1, vbBinaryCompare)
Then you can use a For loop to traverse the array.
Here's a piece of code that I've thrown together that I think meets your needs. I think the variable names are self explanatory, but if not, please follow up.
The code searches each cell in the header row of the origin sheet to see if it exists in the destination sheet. If so, it copies over the corresponding information.
Dim wsOrigin As Worksheet
Dim wsDest As Worksheet
Dim nCopyRow As Long
Dim nPasteRow As Long
Dim rngFnd As Range
Dim rngDestSearch As Range
Dim cel As Range
Const ORIGIN_ROW_HEADERS = 1
Const DEST_ROW_HEADERS = 1
Set wsOrigin = Sheets("Sheet1")
Set wsDest = Sheets("Sheet2")
nCopyRow = ActiveCell.Row
nPasteRow = wsDest.Cells(Rows.Count, 1).End(xlUp).Row + 1
Set rngDestSearch = Intersect(wsDest.UsedRange, wsDest.Rows(DEST_ROW_HEADERS))
For Each cel In Intersect(wsOrigin.UsedRange, wsOrigin.Rows(ORIGIN_ROW_HEADERS))
On Error Resume Next
Set rngFnd = rngDestSearch.Find(cel.Value)
If rngFnd Is Nothing Then
'Do Nothing as Header Does not Exist
Else
wsDest.Cells(nPasteRow, rngFnd.Column).Value = wsOrigin.Cells(nCopyRow, cel.Column).Value
End If
On Error GoTo 0
Set rngFnd = Nothing
Next cel
I have an excel report that relies on 3 source documents for data.
The report pulls and compiles the 3 sources into 1 array. It then loops through the array and assigns the values to the columns of the appropriate row in the appropriate spreadsheet.
I am currently getting a "Run-time error '1004': Application-defined or object-defined error" at a specific point.
The report loops through the array and assigns the cell values successfully until the 6th column which represents "Shift Worked". the value in the array is "Variant/Date" type and = #3:53:54 AM#
Please help, I have scanned the archives for this specific problem and cannot find anything that seems to pertain to this instance.
Code:
Sub Write_Data(v() As Variant)
Dim wb As Workbook
Dim ws As Worksheet
Dim i As Integer, j As Integer
Dim x As Integer, y As Integer
Dim r As Integer, c As Integer
Dim d As Date, d2 As Date
Dim s() As String
Set wb = ThisWorkbook
d = CDate(frmMain.txtDate)
For i = LBound(v, 2) To UBound(v, 2)
sName = v(3, i)
s = Split(sName)
sName = Left(Trim(s(LBound(s))), 1) & Trim(s(UBound(s)))
For Each ws In wb.Sheets
If UCase(Trim(sName)) = UCase(Trim(ws.Name)) Then Exit For
Next
If Not ws Is Nothing Then
r = 5
Do
r = r + 1
If InStr(ws.Cells(r, 1), "-") Then
s = Split(ws.Cells(r, 1), "-")
d2 = CDate(s(LBound(s)))
If d2 = d Then
For j = LBound(v, 1) + 3 To UBound(v, 1)
c = j - 2
ws.Cells(r, c) = v(j, i) ' <- This is where the error
Next j
Exit Do
End If
d2 = 0
End If
Loop Until r > 35
End If
Next i
End Sub
===============
UPDATED:
I figured this out.
Previously, I was doing this:
During the compilation of the array, in order to get the correct value for the 6th field, I used a function to compile 8 Different possible timeclock punches into a total "Shift Worked" Value.
The error was occuring because if there was a missing punch then I was using "Now()" to get the current timestamp. Conceptually this was sound because this report would be run at the end of every hour and if the agent wouldn't have punched out yet it would add their time up until the current hour by using the "Now()" function.
The problem is this...
When running the report for a previous date, the calculation would somehow result in a correct looking "Variant/Date" type but cause a '1004' runtime error when trying to assign it to a cell.
I fixed this by adding 2 parameters for user input before running the procedure.
1. "Date" & 2. "Hour". When encountering a missing punch, instead of using "Now()" I replace that with my own variable "dNow" which simple takes the date parameter and adds the hour to it to get the latest possible time.
Here is the corrected procedure that is used to create the value that was causing an error when trying to place it. Notice the variable "dNow" and the way it is assigned.
Function Calc_Time(t1 As Date, t2 As Date) As Date
Dim dNow As Date
dNow = DateAdd("h", frmMain.cmbHour, DateValue(frmMain.txtDate))
Dim t As Date
If t1 <> 0 And t2 <> 0 Then
t = (TimeValue(t2) - TimeValue(t1))
ElseIf t1 <> 0 And t2 = 0 Then
t = (TimeValue(dNow) - TimeValue(t1))
ElseIf t1 = 0 And t2 <> 0 Then
t = t2
ElseIf t1 = 0 And t2 = 0 Then
t = 0
End If
Calc_Time = t
End Function
I've searched far and wide and I can't quite find anything to fit my needs.
The situation:
I have two lists of data with the same type data in each column (10 columns but the last 2 are useless), but the lists are of varying length (currently 55k in one, 18k in the other). The longer list is going to be a running list of items with the most up to date data in each column for the unique ID # in column A. The other list is linked to a SharePoint list that I update a couple times each day.
The need:
I need the list that updates from SharePoint to be compared to the running list. If there are matching Unique ID #'s in the lists, then the running list needs to be updated to the pulled data. If the running list doesn't contain a Unique ID that is in the pulled list, the new line needs to be added to the running list (which will be sorted later).
I first tried doing this with cell references in two for loops and for only 10 rows this worked fine. When I tried running it for every line, I had problems. So I tried using arrays instead, but this is new territory for me. The code seems to be working, but it's taking a really long time to run (I've let it go for 10 minutes before force stopping). I've tried adding some efficiency increases like turning off screen updating and calculations, but they shouldn't have any effect since I'm using arrays and not actually updating the cells until the array comparison is finished. If arrays are more efficient, great, but I don't know how to combine the data from the pulled list's array to the running list's array.
Here is the code that I have so far:
Sub Data_Compile_Cells()
Dim sdata As Worksheet, spull As Worksheet
Dim p As Long, d As Long, c As Long
Dim lrdata As Long, lrpull As Long
Dim rdata As Range, rpull As Range
Dim Newvalue As Boolean
Dim apull As Variant, adata As Variant
Dim nrows As Long, ncols As Integer
Set sdata = Sheets("Data")
Set spull = Sheets("Data Pull")
Newvalue = "FALSE"
i = 1
apull = spull.Range("A1").CurrentRegion
adata = sdata.Range("A1").CurrentRegion
'lrdata = sdata.Range("A" & Rows.Count).End(xlUp).Row
'lrpull = spull.Range("A" & Rows.Count).End(xlUp).Row
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
sdata.Activate
'*****UniqueID Check******
'Run through list of Unique ID's pulled from SharePoint
For p = 2 To UBound(apull, 1)
'I tried to add a status bar to see if the code was actually running
'Application.StatusBar = "Progress: " & p & " of " & UBound(apull, 1) & " : " & Format(p / UBound(apull, 1), "0%")
'Compare each one to the Unique ID's already listed
For d = 2 To UBound(adata, 1)
'Check for matching Unique ID's
If adata(d, 1) = apull(p, 1) Then
'Check each cell in the row with the matching Unique ID
For c = 2 To 10
'If a cell does not have the same data, replace the Data array value with the value from the Pull array
If adata(p, c) <> apull(d, c) Then
adata(d, c) = apull(p, c)
End If
Next c
'If a match is found, skip to the next p value
Exit For
Else
Newvalue = "TRUE"
'Need code to append new line to Data array
End If
Next d
Next p
'Sort the data
'Range("A2").CurrentRegion.Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlYes
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Any direction would be much appreciated.
This ran in <1 sec for me, using 20k rows "data", ~3k rows "pull" (mix of updates and new).
EDIT: tidied up and added some comments...
Sub tester()
Const NUM_NEW As Long = 20000 'large enough ?
Dim arrPull, arrData, arrDataId, arrNew()
Dim ubP As Long, ubD As Long
Dim numNew As Long, r As Long
Dim v, c As Long
Dim t, tmp, coll As Collection
t = Timer
'grab the current and new data
arrPull = Sheets("Pull").Range("A1").CurrentRegion.Value
arrData = Sheets("Data").Range("A1").CurrentRegion.Value
ubP = UBound(arrPull, 1)
ubD = UBound(arrData, 1)
numNew = 0
ReDim arrNew(1 To NUM_NEW, 1 To 10) 'array for new data
'create a collection to map ID to "row number"
Set coll = New Collection
For r = 1 To ubD
coll.Add Item:=r, Key:=arrData(r, 1)
Next r
For r = 1 To ubP
tmp = arrPull(r, 1)
v = 0
'collection has no "exists" function, so trap any error
On Error Resume Next
v = coll.Item(tmp)
On Error GoTo 0
If v > 0 Then
'Id already exists: update data
For c = 2 To 10
arrData(v, c) = arrPull(r, c)
Next c
Else
'new Id: add to the "new" array
numNew = numNew + 1
If numNew > NUM_NEW Then
MsgBox "Need larger `new` array!"
'a more sophisticated approach would be to dump the full
' array to the sheet and then redimension it for more
' data...
Exit Sub
End If
For c = 1 To 10
arrNew(numNew, c) = arrPull(r, c)
Next c
End If
Next r
'drop updated and new (if any) to the worksheet
With Sheets("Data")
.Range("A1").CurrentRegion.Value = arrData
If numNew > 0 Then
.Cells(ubD + 1, 1).Resize(numNew, 10).Value = arrNew
End If
End With
Debug.Print "Done in " & Timer - t & " sec"
End Sub
You would be better off using MSAccess to do this. Link to both tables and then do an inner join on the id field or which ever field links the items in the two lists.