I am having a problem with finding duplicates in an excel column that is created via VBscript.
I currently am grabbing data from a DB opening an excel file, placing the data within and then sorting the data alphabetically ascending on column E (if this isn't needed it can easily be removed).
Now the problem that I am faced with is that I am trying to find any duplicates within that column E (Errors).
If there is a duplicate I would like to copy the duplicate and paste it into another sheet (column A) that I have created
Set oWS7 = oWB.Worksheets(7)
oWB.Sheets(7).Name = "Dups"
And in column B of oWS7 I would like to put all the corresponding column C's (accounts) from the original worksheet.
So that there would be a 1 Error to many account's ratio. If there are no duplicates I would like to have them left alone. I'm not sure how clear this is but any questions/help on this would be much appreciated.
Thanks in advance.
I'm going to make the following assumptions:
The content in the worksheet starts in the first row
The first row (and only the first row) is a header row.
There are no empty rows between header row and data rows.
The data is already sorted.
If these assumptions apply the following should work (once you put in the correct sheet number):
Set data = oWB.Sheets(...) '<-- insert correct sheet number here
j = 1
For i = 3 To data.UsedRange.Rows.Count
If data.Cells(i, 5).Value = data.Cells(i-1, 5).Value Then
oWS7.Cells(j, 1).Value = data.Cells(i, 5).Value
oWS7.Cells(j, 2).Value = data.Cells(i, 3).Value
j = j + 1
End If
Next
'How To find Repeted Cell values from source excel sheet.
Set oXL = CreateObject("Excel.application")
oXL.Visible = True
Set oWB = oXL.Workbooks.Open("ExcelFilePath")
Set oSheet = oWB.Worksheets("Sheet1") 'Source Sheet in workbook
r = oSheet.usedrange.rows.Count
c = oSheet.usedrange.columns.Count
inttotal = 0
For i = 1 To r
For j = 1 To c
If oSheet.Cells(i,j).Value = "aaaa" Then
inttotal = inttotal+1
End If
Next
Next
MsgBox inttotal
oWB.Close
oXL.Quit
Related
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 two workbooks. One workbook has the calendar dates(Calendar.xlsm) and the other workbook has only the names(Workingdays.xlsm) of my class students. What i'm trying to do is to match the names in Workingdays.xlsm to Calendar.xlsx . If the match is found then copy the entire row (last filled cell) to Workingdays.xlsm.
So far i'm successful in matching the names in the two workbooks but unable to select the entire row for that matched names.
Sub Obtain_days()
' Open Calendar
Dim calendar_wb As Workbook
Dim calendar_ws As Worksheet
Dim Workdays_ws As Worksheet
Set calendar_wb = Workbooks.Open("C:\Users\XXX1\Desktop\Calendar.xlsx")
Set calendar_ws = calendar_wb.Worksheets("Sheet1")
Set Workdays_ws = Workbooks("Workingdays.xlsm").Worksheets("Sheet1")
' obtain dates
Workdays_ws.Activate
last_rw_Workdays = Workdays_ws.Range("A1000000").End(xlUp).Row
last_rw_calendar = calendar_ws.Range("A1000000").End(xlUp).Row
'last_col_calendar = calendar_ws.Range("XFD3").End(xlToLeft).Column
' loop through names <-------------Sucessful in matching names
For i = 3 To last_rw_Workdays
findval = Workdays_ws.Range("A" & i).Value
For j = 5 To last_rw_calendar
If calendar_ws.Range("A" & j).Value = findval Then
'calendar_ws.Range("C" & last_col_calendar).Copy
calendar_ws.Cells(j, 32).Resize(1, 25).Copy Destination:=Workdays_ws.Cells(i, 3).Resize(1, 2) '<---failed in this step, copying irrelevant cell reference
'ActiveSheet.Range((last_rw_calendar, 1),(last_rw_calendar, last_col_calendar)).Copy
Workdays_ws.Activate
'Workdays_ws.Range("B1000000").End(xlUp).Offset(1, 0).PasteSpecial
End If
Next j
Next i
End Sub
Failed to copy the entire row (Till last filed cell). Any help would be much appreciated
Without more details, I believe you actually want:
calendar_ws.Cells(j, 1).Resize(1, 25).Copy Destination:=Workdays_ws.Cells(i, 3)
This is assuming the "calendar_ws" row has 25 columns you want to copy over to "Workdays_ws" starting in column "C".
I am working with a VB macro. Essentially what I am trying to do is for the macros to read the input and first determine whether or not a cells ID number matches the one in the row. Example: If row 1 has an ID of 1122 and rows 2,3,4 and 5 all match, I want the macro to read that and create a count in the NbrOfA cell. Once it realizes that there is not an ID match it moves on to the next ID and looks for matches of that ID number and continues to create a count. While it is doing this, I also need it to read from another column that has specific strings such as "open", "closed" ect. read that input, and create a separate row titled NbrofOpenA. Once it runs out of data, I then want to have a singular cell that shows the number of actions (NbrOfA) that match the ID number as well as the number of open actions (NbrOfOpenA).
Currently I receive the error: “compile error: sub or function not defined” highlighting the Set Cell(Sheet2.Cells(FirstRowOfI, 23) = NbrOfA
Attached in the excel sheet attached it shows 2 cells deleted. They will not actually be deleted, just wanted to give an idea of what I was looking for
Sub ACount()
Dim FirstRowofI
Dim NbrOfA as Integer
Dim NbrOfOpenA as Integer
Row = 2
Set FirstRowofI = (Sheet2.Cells.Range(Row, 14))
NbrOfA = 0
NbrOfOpenA = 0
If (Sheet2.Cells(Row, 14).Value <> "") Then
NbrOfA = 1
If (Sheet2.Cells(Row, 22) <> "Closed") Then
NbrOfOpenA = 1
Set Row = FirstRowofI
Row = Row + 1
Do While (Sheet2.Cells(Row, 14) = (Sheet2.Cells(FirstRowofI, 14)))
NbrOfOpenA = NbrOfOpenA + 1
If (Sheet2.Cells(Row, 22) <> "Closed" Then
NbrOfOpenA = NbrOfOpenA + 1
Range(Row).EntireRow.Delete
Return
End If
Set Cell(Sheet2.Cells(FirstRowofI, 23)) = NbrOfA
Set Cell(Sheet2.Cells(FirstRowofI, 24)) = NbrOfOpenA
Loop
End Sub
[1
Do you need VBA? You can easily achieve what you're looking for with formulas, heck even a Pivot Table! Here's an example with formulas:
I have a table in excel with a lot of data and dates. Like this:
I open a second sheet and created a formula to extract data from the first sheet that fall between two dates. Like this:
Now I want to be able to change the data on the new sheet and the old sheet will automatically get updated. For example I want to be able to change N to Y under Shipped and have the first sheet be updated to Y.
Can anyone tell me how I can do that?
please use VBA:
open VBA editor (ALT+F11), add new module and paste code below.
After enterering all corrections to your second sheet, please run macro.
It isn't optimal solution but it should work:
Sub CopyChangesInSheepment()
Set wksSheet1 = Worksheets("sheet1") 'put name of yours FIRST sheet here
Set wksSheet2 = Worksheets("sheet2") 'put name of yours SECOND sheet here
F = wksSheet1.Range("a1").CurrentRegion.Rows.Count
S = wksSheet2.Range("a6").CurrentRegion.Rows.Count
For j = 6 To S
For i = 1 To F
id1 = wksSheet1.Cells(i, 1)
id2 = wksSheet2.Cells(j, 1)
ord1 = wksSheet1.Cells(i, 8)
ord2 = wksSheet2.Cells(j, 8)
If id1 = id2 And ord1 = ord2 Then 'check if order number and sku are the same
wksSheet1.Cells(i, 24) = wksSheet2.Cells(j, 15) 'column shipped is 24. column (X) in sheet1 and 15. (O) in sheet2
End If
Next i
Next j
End Sub
Ive written a macro that takes some source data and writes it onto several sheets, which id like to remain hidden before and after the macro has run. Having written the Macro, when I run it it only updates a few records on each sheet (for instance on the first hidden sheet it updates 21 rows out of over 1000. What is the reason for this happening? Surely it should update them all or none of them? Im not getting any errors either. Ive tried
Application.ScreenUpdating = False
Worksheets("FT Raw").Visible = True
Worksheets("L1").Visible = True
Worksheets("L2").Visible = True
Worksheets("L3").Visible = True
Worksheets("L4").Visible = True
But still only 21 rows get updated.
Update: This is the code that is running on each sheet
endval = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To endval
If Not Sheets("FT Raw").Cells(i, "A") = "" Then
splitted = Split(Sheets("FT Raw").Cells(i, "A"), ",")
Sheets("FT Raw").Cells(i, "B") = splitted(0)
Sheets("FT Raw").Cells(i, "C") = splitted(1)
Sheets("FT Raw").Cells(i, "D") = splitted(2)
If Sheets("FT Raw").Cells(i, "D") = "1" Then
Sheets("L1").Cells(j, "A") = Trim(splitted(0))
Sheets("L1").Cells(j, "B") = Trim(splitted(3))
j = j + 1
End If
End If
Next i
Ok Edit. You need to specify the Sheet("FT Raw") in your endval calc.
Try this set endval = Sheets("FT Raw").Cells(Sheets("FT Raw").Rows.Count, 1).End(xlUp).Row and proceed with the remainder of your code.
(You could also use endval = Sheets("FT Raw").UsedRange.Rows.Count only if you don't have blank cells at the top of the column)
Lucky last, you don't have to unhide these sheets at all to run the code. By all means do so to debug but when running in anger it's not necessary.
This has nothing to do with the hiding of sheets - even if a sheet is hidden, you can still modify it with VBA. (Only if it is protected, you need to unprotect it.)
Lookig at your code, I do not see, where j is initialized - and under which circumstances column D in your sheet FT rawis equal to "1".
I suggest you initialize j in the top, e.g. if you want to add the rows using
j = Sheets("L1").Range(Rows.Count, 1).End.(xlUp).Row + 1
Then, after running the macro (for a check), filter column D in your raw sheet with an Autofilter for the value 1 and see if that matches the number of entries in sheet L1.