I have 2 sheets, Transfer Data and Keep List. My current code is below.
Dim cfind, cfind1, delete, c As Range
Dim x As String
Dim i, j As Integer
Set td = ThisWorkbook.Worksheets("Transfer Data")
Set delete = Range(cfind.Offset(0, 0), cfind.End(xlDown))
Set cfind = dl.Cells.Find(What:="Location Name", lookat:=xlWhole)
Set delete = Range(cfind.Offset(0, 0), cfind.End(xlDown))
j = td.Range("H2").End(xlDown).Row
For i = j To 1 Step -1
x = td.Cells(i, "H").value
Set cfind1 = delete.Find(What:=x, lookat:=xlWhole)
If cfind1 Is Nothing Then
td.Cells(i, "H").EntireRow.delete
End If
Next
So the idea of this is that whatever is on the Keep List (i.e. Column B on Keep List refers to Column H of Transfer Data, and if the value isnt on this Keep List, the entire row gets deleted.
My code works but it takes awhile, especially the initial run. for the rest of the column, I just re-use the code above and just adjusted the header name accordingly to what is on the Keep List, start with column B, then it works on the next list, which is Column C (Department Id).
Is there a more faster/efficient way to code this? Also there may be more columns added to the Keep List in the future, so flexibility to include future columns would also be helpful. The column headers for both tabs will be exactly the same but not necessarily in the same order.
Transfer Data
Keep List
Related
So basically, I have a table, where in Column A, I have a repeated list of data with multiple duplicates. In Column B, I have different sets of data related to column A, and then same as Column C. What I wish to have excel do for me is to give me the table (A15:C18), where the Column A data is one cell for each value, and then all the related information is shown right next to it in a concatenated manner.
My approach so far
So basically, what I have done so far is the following approach:
Since Column A are the only thing common in defining the different
lines, so I came up with a way to define each line as a unique line,
using the following =(A1&"--"&countif($A$1:A1;A1). This formula then
helps me identify each row as A--1, A--2, A--3, B--1, B--2 and so
on. Hence I have numbered each data in each row, in a way.
Since I want a unique list, therefore using VBA I get a unique list of variables in a new sheet. Hence, I get the list of just A, B and C in a column instead of them being duplicates.
Once I have the unique list, I then use the =countif() function to count how many times, the variable shows up in the original list (Column A). Like for example, A shows up three times, hence I know that I need to extract 3 rows for this specific data point.
Then using that information, I then proceed to use the =vlookup() function, using the equation =VLOOKUP(A&"--"&1;TABLE;COLUMN)&", "&VLOOKUP(A&"--"&2;TABLE;COLUMN)&", "&VLOOKUP(A&"--"&3;TABLE;COLUMN) .... so on depending on how many times the variable is in the list.
Finally, for example, I then write the vlookup code, and I can then extract all the cells into one place.
PROBLEMS and HELP
So the above approach I have described works on a pilot scale with lots of manual changes for different data points. The problems are the following:
The process of using =vlookup() is based on the =countif() function. I wrote down a very long formula using IF statements saying that =IF(COUNTIF()=1;VLOOKUP(VAR&--&1;TABLE..);IF(COUNTIF()=2;VLOOKUP(VAR&--&1;TABLE..)&","&VLOOKUP(VAR&--&2;TABLE..); ...
Basically, I wrote the IF statement depending on the value of the countIf value. If it is 1, then extract the values for --1, but if it is 2, then do it for --1 and --2, and vice versa. But this is such a bad approach because I can not write this equation for 100 duplicates and if a data point shows up more than 100 Times, then this approach is useless. hence, I would like to know, if it is somehow possible to use a loop VBA code for excel to do a vlookup? So if countif is 4, then do a vlookup from --1 until --4 and so on?
Another limtation is that even though B shows up 2 times in column A, but it only has 1 data point in Column B, and that is the information I need. Hence I should be focusing on that instead of using the =countif() on Column A. **Any suggestions on how I can count, how much information is infront of a data point in the second column? The data in Columns B and C are unique so there are no duplicates. **
I am stuck with the above two points, which kind of makes up the engine of the workbook. So any help or suggestion on how to approach this problem would be greatly appreciated!
Below is the updated image to show the general approach:
Interesting problem, here's my approach.
Pre-requisites:
You need Microsoft Scripting Runtime: Tools -> References -> Microsoft Scripting Runtime -> check the box
There are 2 components of this code.
First the sub you will run:
Sub Concatenate_Data()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("YourWorksheetsName")
Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim r As Long
Dim dict As New Scripting.Dictionary
Dim letterStr As String
For r = 2 To lastRow
letterStr = ws.Cells(r, 1).Value
If dict.Exists(letterStr) Then
If Not ws.Cells(r, 2).Value = "" Then
dict(letterStr).Candy = dict(letterStr).Candy & ", " & ws.Cells(r, 2).Value
End If
If Not ws.Cells(r, 3).Value = "" Then
dict(letterStr).Juice = dict(letterStr).Juice & ", " & ws.Cells(r, 3).Value
End If
Else
dict.Add letterStr, New Letter
If Not ws.Cells(r, 2).Value = "" Then
dict(letterStr).Candy = ws.Cells(r, 2).Value
End If
If Not ws.Cells(r, 3).Value = "" Then
dict(letterStr).Juice = ws.Cells(r, 3).Value
End If
End If
Next r
Dim k As Variant
r = 2
For Each k In dict.Keys
ws.Cells(r, 5).Value = k
ws.Cells(r, 6).Value = dict(k).Candy
ws.Cells(r, 7).Value = dict(k).Juice
r = r + 1
Next
End Sub
Next is the Class (it is named Letter):
Public Candy As String
Public Juice As String
Here is the input and output I get:
Good Luck!
Background: I'm relatively new to VBA, but I see the value in becoming more comfortable using the skillset.
Goal: Move unorganized data (srce) from one spreadsheet into a different more structured spreadsheet (dest) that can later be uploaded into a software application. I have ~500 of these spreadsheets that need to be migrated, so there is an immense amount of time that could be saved by automating this.
Data: The data is a history of truck maintenance. Periodic maintenance takes place throughout the year with multiple services often performed during a single maintenance routine. Under each routine maintenance, there is a date, # of hours on the vehicle when maintenance is performed, and the type of service performed (consistently column "A").
Data Structure: All service types are contained in column A. Starting in column C & D, I have all of the dates the services performed in 2021 from C11:C34. The # of hours the vehicle has operated at the time of maintenance are contained in cells D11:D34. Subsequently, the dates and # of hours for each maintenance in 2022 are contained in columns E and F.
Challenge: While moving down the rows and before switching to the next column, I need to:
Check for repeat dates
Copy the type of services performed at that date
Paste all of those services performed under a single line item in my destination spreadsheet starting in column T and ending in Column Y (In case ~8 services are performed under a single maintenance routine.)
Question:
How can I complete the above challenge without duplicating entries and keep all services performed on the same date within a single line in my dest spreadsheet?
Below is my code thus far (I've left a comment in the section that is where I intended to craft an answer to my dilemma):
Sub VehicleDataExport()
Application.ScreenUpdating = False
'Set reference cell for output called "dest"
Set dest = Sheets("Dest").Range("A2")
'Initialize counter for destination for how many rows down we are so far
dindx = 0
'Set reference cell for source data called "srce"
Set srce = Sheets("Srce").Range("C11")
'Set reference cell for source for how many columns over we are
cindx = 0
'Set the service type index
Set serviceindex = Sheets("Srce").Range("A11")
'Collect name, vin, and in-service date
vehicle_name = Sheets("Srce").Range("A1")
vehicle_vin = Sheets("Srce").Range("B7")
started_at = Sheets("Srce").Range("B8")
'Go over from anchor column while not empty
While srce.Offset(-1, cindx) <> ""
'set row index so that it can restart everytime you switch columns
rindx = 0
'Cycle down through rows until an "DATE" is found
While srce.Offset(rindx, cindx) <> "DATE"
'Set counter for duplicate index so the program will move through the data while looking for duplicate DATES
duplicateindx = 0
'If statement to determine if something is in the cell - 2nd header row
If srce.Offset(rindx, cindx) > 0 Then
'True Case: copy the date, hours, and service type
service_date = srce.Offset(rindx, cindx)
service_hours = srce.Offset(rindx, cindx + 1)
service_type = serviceindex.Offset(rindx, 0)
meter_void = ""
'Properly label and account for Dot Inspection
If service_type = "DOT Inspection" Then
service_hours = 0
meter_void = True
'secondary_meter_value needs to be 0
'secondary_meter_void needs true
End If
'CHECK FOR DUPLICATE DATES AND COPY THEM TO A SINGLE ROW IN THE DESTINATION
'Paste all of the numbers into a destination row
dest.Offset(dindx, 0) = vehicle_name
dest.Offset(dindx, 1) = vehicle_vin
dest.Offset(dindx, 2) = started_at
'Variable inputs
dest.Offset(dindx, 3) = service_date
dest.Offset(dindx, 13) = service_hours
dest.Offset(dindx, 17) = service_type
dest.Offset(dindx, 14) = meter_void
'Add to both the row and destination indexes
rindx = rindx + 1
dindx = dindx + 1
'If no inspection is found, move down one row
Else: rindx = rindx + 1
'End if statement
End If
'end column specific while loop
Wend
'add two to the column index - account for both the date and hours column
cindx = cindx + 2
'End the initial while loop
Wend
Application.ScreenUpdating = True
End Sub
This really sounds like a job for PowerQuery but if I was to tackle it with VBA I'd use a Scripting.Dictionary. I would also write a small data class that includes all of your service types as Boolean.
I don't fully understand your data structure but some pseudo code might look like this:
Const SRVCECOL As Long = 1
Const HOURSCOL As Long = 2
Function ExtractTransformServiceData(src As Workbook) As Object
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim svcDates As Range
Set svcDates = src.Sheets(1).Range("C11:C34")
Dim svcDate As Range
For Each svcDate in svcDates
Dim tsd As TruckServiceData
If dict.Exists(svcDate.Value) Then
Set tsd = dict.Item(svcDate.Value)
Else
Set tsd = New TruckServiceData
dict.Add svcDate.Value, tsd
End If
tsd.SetHoursForService( _
svcDate.Offset(0, SRVCECOL).Value, _
svcDate.Offset(0, HOURSCOL).Value)
Next svcDate
Set ExtractTransformServiceData = dict
End Sub
I have a stacked column graph and i want to hide/show some of the categories on certain conditions. All solutions, i've found, work for series, but in need for categories.
Thank you in advance.
I recorded a macro while I filtered my chart to hide category 2, and here's what the recorder gave me:
ActiveChart.ChartGroups(1).FullCategoryCollection(2).IsFiltered = True
I found a workaround. However, maybe somebody has a more elegant solution, it would be much appreciated.
1st i swap series and categories.
chartSheet.ChartObjects("chart").Chart.PlotBy = xlColumns
2nd then i check which column is hidden and save an index for FullSeriesCollection. With a little convoluted way to get the sheet name and column address, where the data is located.
Dim i As Long, k As Long
Dim tmp() As Variant
Dim sh As String, col As String
For i = 1 To Sheet2.ChartObjects("tst").Chart.SeriesCollection.Count
If Worksheets(Split(Split(Sheet2.ChartObjects("tst").Chart.SeriesCollection(i).Formula, ",")(2), "!")(0)) _
.Range(Split(Split(Sheet2.ChartObjects("tst").Chart.SeriesCollection(i).Formula, ",")(2), ":")(1)).EntireColumn.Hidden = True Then
k = k + 1
ReDim Preserve tmp(1 To k)
tmp(k) = i
End If
Next i
3rd after that i run through all the hidden columns and hide the corresponding data. I couldn't combine 2nd and 3rd, because if any other column, then the last one, is hidden, vba gives an error. Since it tries to access SeriesCollection, which does not exits anymore.
For i = 1 To UBound(tmp)
chartSheet.ChartObjects("chart").Chart.FullSeriesCollection(tmp(i)).IsFiltered = True
Next i
4th and lastly i flip series and categories back around.
chartSheet.ChartObjects("chart").Chart.PlotBy = xlRows
I have a long excel list (+10k rows) and a column with ordernumbers.
Unfortunatelly some orders were deleted.
My question is simple but to achieve probabily not: I want to count the deleted rows, basically the missing ordernumbers.
A hint is aprechiated.
endo
I don't know how to do this using Excel code, but if you go to the bottom and get the last order number, you can calculate how many there should be with
last order number - first order number = expected amount
How many their actually are would be
last order index - first order index = actual amount
Then you can do
expected amount - actual amount = missing order numbers
Of course, this assumes there are no blank rows between order numbers, and that you only need to do this once. (you prob want a function or something to have it update as you change the spreadsheet)
This covers blank rows and numbers missing from the sequence (however, if your min/max are deleted, this can't detect that). It's similar to #shieldgenerator7's answer.
No sorting necessary for this.
EDIT: As sheildgenerator7 pointed out, this assumes that you expect all of your order numbers to be sequential.
=(MAX(A2:A26)-MIN(A2:A26)+1)-COUNTA(A2:A26)
You can now count blanks in Excel with a simple function called COUNTBLANK. If you know the ending row number (for example, if the data were in A1 to A10000), you can use this formula:
=COUNTBLANK(A1:A10000)
If the numbers are sequential it is pretty easy.
Sort by order number
Count in B4
=(A4-A3)-1
Sum in B17
=SUM(B3:B16)
Here's something I put together to identify missing numbers and optionally print the list out on a new workbook.
You can change the minimum and maximum number, and it does not matter if the list is sorted or not.
Sub FindMissingNumbers()
Dim lstRange As Range
Dim r As Long
Dim lowestNumber As Long
Dim highestNumber As Long
Dim missingNumbers() As Variant
Dim m As Long
Dim wbNew As Workbook
'## Set this value to the lowest expected value in ordernumber'
lowestNumber = 0
'## Set this value to your highest expected value in ordernumber'
highestNumber = 100
'Assuming the order# are in column A, modify as needed:'
Set lstRange = Range("A1", Range("A1048576").End(xlUp))
For r = lowestNumber To highestNumber
'## Check to see if this number exists in the lstRange
If IsError(Application.Match(r, lstRange, False)) Then
'## Add this number to an array variable:'
ReDim Preserve missingNumbers(m)
missingNumbers(m) = r
m = m + 1
End If
Next
If MsgBox("There were " & m & " missing order numbers" _
& vbNewLine & "Do you want to print these numbers?", vbYesNo) = vbYes Then
Set wbNew = Workbooks.Add
With wbNew.Sheets(1)
' For r = LBound(missingNumbers) To UBound(missingNumbers)
' .Range("A1").Offset(r, 0).Value = missingNumbers(r)
' Next
.Range("A1").Resize(UBound(missingNumbers) + 1) = _
Application.WorksheetFunction.Transpose(missingNumbers)
End With
Else:
End If
End Sub
I have a vba script which is supposed to copy data from one sheet to another. It does by means of three nested for loops. Stepping through the code in debugging these appear to work perfectly, but when the vba script is run they appear to stop too early. Otherwise the vba script works.
I have been staring at this for hours and cannot for the life of me see what would cause the loops to stop early. I'm hoping the solution is something simple I've missed, but I am at a genuine loss, not for the first time since I started this.
The sheet is organised as follows:
Sheet1, contains the data to be copied.
Each row contains a seperate response, of which there are 55 in the test data
The sheet contains nine blocks of data, named Episode 1-9. Each episode contains column where an integer represent a start, end and interval time.
In the test data each episode is identical except for the start/end times.
The maximum value for EndTime is 36
The test data is over the first four Episode blocks only, so Episode4 contains EndTime=36 for each row
Sheet2, where the data is to go
-First column contains each RespondentID copied over 36 rows
-Second column contains numbers 1-36, thus representing that time slot for that respondent
-11 Columns after that contain the area where the data copied from sheet1 for that Respondent/Time is put. These 36x11 areas are named "Response1-55" in the test data
The logic of the vba script is as follows:
Counters:
- n counter for number of respondents
- r counter for number of episodes
- i counter for rows within the responses being copied to.
->For each response (starting with n=1 to Respondents)
--> Select the first episode (Starting with r=1 to 9)
--->For each episode
--->Read the start, end and interval times
--->Starting from i = Start to i=End copy the relevant cells from the n'th row of the r'th episode
--->Copy those cells to the i'th row of the current response on sheet2
--->When you reach the EndTime of the current episode, go to the next one (next r)
-->If the episode you just finished has 36 as its EndTime then go to the next response, or continue till you run out of episodes.->Next Response
In debugging the code appears to do exactly this.
However when I run the vba script on the test sheet it works only for episodes 1 and 2. The data from episodes 3 and 4 is not copied. Nothing is copied in its place, and the data which IS copied is correct in every respect. There are no error messages at any point.
If anyone could suggest why this might be happening I would build unto them an actual church. The answer could also be added here: https://stackoverflow.com/questions/119323/nested-for-loops-in-different-languages Which does not yet have a section for VBA.
A link to the test sheet is here: http://dl.dropbox.com/u/41041934/MrExcelExample/TornHairExampleSheet.xlsm
The relevant part of the code is here
Sub PopulateMedia()
Application.ScreenUpdating = False
'Count the total number of response rows in original sheet
Dim Responses As Long, n As Integer, i As Integer, r As Integer
Responses = (Sheets("Sheet1").UsedRange.Rows.Count - 3) ' equals 55 in test sheet
'For each response...
For n = 1 To Responses
i = 1 'Reset i for new response
Dim curr_resp As Range
Set curr_resp = Sheets(2).Range("Response" & n) 'Define a range containing all response data
For r = 1 To 9 'For each episode...
Dim curr_ep As Range 'Define a range containing episode data for all responses
Set curr_ep = Sheets(1).Range("episode" & r)
Dim Stime As Integer, Etime As Integer, Itime As Integer 'Variables contain start, end and inter-episode times
Stime = curr_ep.Cells(n, 1)
Etime = curr_ep.Cells(n, 17)
Itime = curr_ep.Cells(n, 19)
For i = Stime To (Etime + Itime) 'for each time-slot...
If i <= Etime Then
Dim a As Variant
a = curr_ep.Range(curr_ep.Cells(n - 3, 1), curr_ep.Cells(n - 3, 11))
curr_resp.Rows(i) = a 'Copy data from above current episode to current response for slots between Stime and Etime
End If
Next i
If Etime = 36 Then Exit For
Next r
Next n
Application.ScreenUpdating = True
End Sub
To disclose, I have already had help on this project from this site, VBA copy from a union of two ranges to a row of another range but the code has been changed slightly since then and this is a different problem.
Once more, thank you enormously for any help which might come of this. I have been staring at this for hours and do not see where the error is. Any guidance at all greatly appreciated.
I would post this as a comment if I could but this is too long. So here it is as a query /potential solution
I think your range references are the issue
The code below is a cut-down version of your code
curr_ep is a named range of episode1. It has a range address of $Y$4:$AQ$58
When you loop through the a variant you are setting a range with this syntax
a = curr_ep.Range(curr_ep.Cells(n - 3, 1), curr_ep.Cells(n - 3, 11))
which is equivalent to
a = curr_ep.Range("Y2:AQ2")
which means you are actually looking at AW2:BG2 not Y2:AQ2 which is what I think you may have intended, i.e. you are building in an unintended offset
Sub PopulateMedia()
n = 1
r = 1
Dim curr_ep As Range
Dim curr_test As Range
Set curr_ep = Sheets(1).Range("episode" & r)
Set curr_test = curr_ep.Range(curr_ep.Cells(n - 3, 1), curr_ep.Cells(n - 3, 11))
End Sub