I have a sheet with some data and another sheet that is empty with just column headers. I wanted to copy data from the initial sheet into the other sheet based on a criteria where the region should be "Africa".
I used the code below which is copying the data but it is copying the first row from the initial sheet multiple times and not all the data rows where the region is "Africa". Here is a snippet of my code:
'Assigning the arrays to variables to return column index number
ws1Headers = getIndexes(ws1.Rows(4), mHeaders)
ws2Headers = getIndexes(ws2.Rows(2), soHeaders)
'Setting first and last row for the columns in both sheets
ws1SORow = 5 'The row we want to start processing first
ws1EndRow = ws1.UsedRange.Rows(ws1.UsedRange.Rows.count).Row
ws2SORow = 3 'The row we want to start search first
ws2EndRow = ws2.UsedRange.Rows(ws2.UsedRange.Rows.count).Row
'iterate through search terms
For i = ws1SORow To ws1EndRow 'first and last row
searchKey = ws1.Range("A" & i)
If (searchKey = "") Then
For j = ws2SORow To ws2EndRow 'first and last row
foundKey = ws2.Range("O" & j)
'Copy result if there is a match
If (foundKey = "Africa") Then
'Copying data where the headers match
For k = LBound(ws2Headers) To UBound(ws2Headers)
ws1.Cells(i, ws1Headers(k)) = ws2.Cells(j, ws2Headers(k))
Next k
Exit For
End If
Next
End If
Next
I have a function that gets the index of the headers and the header names are also defined which I have not included as it is a lot of code. Would highly appreciated any help for the query posted.
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 am trying to restructure inside one drive using automate a function, but not sure if multi header table can be restructured. Thank you in advance for your help.
I want to restructure it in this format -
Customer
You can loop through the dates in 1st row and create a nested loop which goes through the customers one by one and get the values according to the actual column and row. You should save the result on a new sheet.
Sub Format_Table()
lastRowOnNewFormatSheet = 2 'last empty row on newSheet
'Loop through the columns with step 3
For i = 2 To Cells(1, Columns.Count).End(xlToLeft).Column Step 3
'Loop through the rows at every column
For j = 3 To Cells(Rows.Count, 1).End(xlUp).Row
Sheets("newFormat").Cells(lastRowOnNewFormatSheet, 1).Value = Sheets("oldFormat").Cells(j, 1) 'customer name
Sheets("newFormat").Cells(lastRowOnNewFormatSheet, 2).Value = Sheets("oldFormat").Cells(1, i) 'date
Sheets("newFormat").Cells(lastRowOnNewFormatSheet, 3).Value = Sheets("oldFormat").Cells(j, i) 'budget
Sheets("newFormat").Cells(lastRowOnNewFormatSheet, 4).Value = Sheets("oldFormat").Cells(j, i + 1) 'actual
lastRowOnNewFormatSheet = lastRowOnNewFormatSheet + 1 'update last empty row on newSheet
Next j
Next i
End Sub
Data Sheet
I have two workbooks with the same content. I am copying and pasting the amount values from one workbook sheet to another when the project number and division is the same. The amount has to be pasted in the row where there is a match. The issue I am facing is all the amounts are getting copied but not pasted near the respective match.
The code I have used is as follows:
ws1PRNum = "E" 'Project Number
ws1Div = "I" 'Division
ws2PRNum = "E" 'Project Number
ws2Div = "I" 'Division
'Setting first and last row for the columns in both sheets
ws1PRRow = 5 'The row we want to start processing first
ws1EndRow = wsSrc.UsedRange.Rows(wsSrc.UsedRange.Rows.count).Row
ws2PRRow = 5 'The row we want to start search first
ws2EndRow = wsDest.UsedRange.Rows(wsDest.UsedRange.Rows.count).Row
For i = ws1PRRow To ws1EndRow 'first and last row
searchKey = wsSrc.Range(ws1PRNum & i) & wsSrc.Range(ws1Div & i) 'PR line and number is Master Backlog
'if we have a non blank search term then iterate through possible matches
If (searchKey <> "") Then
For j = ws2PRRow To ws2EndRow 'first and last row
foundKey = wsDest.Range(ws2PRNum & j) & wsDest.Range(ws2Div & j) 'PR line and number in PR Report
'Copy result if there is a match between PR number and line in both sheets
If (searchKey = foundKey) Then
'Copying data where the rows match
wsDest.Range("AJ5", "AU1200").Value = wsSrc.Range("AJ5", "AU1200").Value
wsDest.Range("BB5", "BM1200").Value = wsSrc.Range("BB5", "BM1200").Value
wsDest.Range("BT5", "BU1200").Value = wsSrc.Range("BT5", "BU1200").Value
Exit For
End If
Next
End If
Next
This is the area that is causing an issue. As seen in the picture the amounts are pasted even in rows where the division and project number are empty. Any answer for the same would be highly appreciated as I am not well versed with VBA.
You can do this:
wsDest.Range("AJ" & j, "AU" & j).Value = wsSrc.Range("AJ" & i, "AU" & i).Value
'etc...
or with a bit less concatenation:
wsDest.Rows(j).Range("AJ1:AU1").Value = wsSrc.Rows(i).Range("AJ1:AU1").Value
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 have the following piece of code I got there for copy a range of columns in another workbook. The issue is that I need to evaluate first some columns before copy the values. I'm using Case for this but I don't know passing the result, I was thinking in an array?
For i = LBound(arrayOrigen) To UBound(arrayOrigen)
With Workbooks("facturas.xlsx").Worksheets("FACTURAS")
lastrowOrig = Application.Max(2,Cells(.Rows.Count,arrayOrigen(i)).End(xlUp).Row)
'For each cell in column D in source ,if is 0 put 0 in each cell target(destination) column(E)_'
' is not then put a formula in target column'
If i = 3 Then
Set Column3 = .Range(.Cells(2, arrayOrigen(i)), .Cells(lastrowOrig, arrayOrigen(i)))
For Each xCell In Column3
Select Case True
Case xCell.Value = 0
result = 0
Case Else
result = "=RC[-1]*0.21"
End Select
**Sheets("RESUMEN").Range(arrayDestino(i) & lastrowDes).Resize(lastrowOrig - 2).Value =** _
result
'array is needed for store the diferents result for each cell and dumping in the destination
'column all at once?'
Next
Else 'for the rest of columns copy entire column whith the same values'
Sheets("RESUMEN").Range(arrayDestino(i) & lastrowDes).Resize(lastrowOrig - 2).Value = _
.Range(.Cells(2, arrayOrigen(i)), .Cells(lastrowOrig, arrayOrigen(i))).Value
End If
End With
Next
Now I'm not able to show the result of Case in the destination columns for each cell, instead of this, it dumps all the column every time that Case change