After countless efforts to keep the array "newvarray" within range, I am now running into a result of an empty array from a 278 line column. I believe this is also the root cause of my endgame function not executing (pasting unmatched values into the rolls sheet)?
Clarification: the actualy empty cells report on locals as "Empty", the columns with string report as " "" "
Dim oldsht As Worksheet
Dim newsht As Worksheet
Dim rollsht As Worksheet
Dim a As Integer
Dim b As Integer
Dim c As Integer
Set oldsht = ThisWorkbook.Sheets("Insert Yesterday's Report Here")
Set newsht = ThisWorkbook.Sheets("Insert Today's Report Here")
Set rollsht = ThisWorkbook.Sheets("Rolls")
Dim OldVArray(), NewVArray(), RollArray() As String
ReDim Preserve OldVArray(1 To oldsht.Range("a" & Rows.Count).End(xlUp).Row - 1, 5 To 5)
ReDim Preserve NewVArray(2 To newsht.Range("a" & Rows.Count).End(xlUp).Row, 5 To 5)
ReDim Preserve RollArray(1 To rollsht.Range("a" & Rows.Count).End(xlUp).Row - 1, 3 To 3)
For a = 2 To oldsht.Range("E" & Rows.Count).End(xlUp).Row
OldVArray(a, 5) = oldsht.Cells(a, 5)
Next a
For b = 2 To newsht.Range("E" & Rows.Count).End(xlUp).Row
NewVArray(b, 5) = newsht.Cells(b, 5)
Next b
For c = 2 To rollsht.Range("C" & Rows.Count).End(xlUp).Row
RollArray(c, 3) = rollsht.Cells(c, 3)
Next c
Dim Voyage As String
For a = 2 To UBound(OldVArray)
Voyage = OldVArray(a, 5)
For b = 2 To UBound(NewVArray)
voyage2 = NewVArray(b, 5)
If voyage2 <> Voyage Then
If voyage2 <> "" Then
For Each cell In NewVArray
voyage2 = rollsheet.Range("C:C")
Next
End If
End If
Next
Next
Here are snips of sample idea, highlighted are the rows that need to be found, and the voyage that changed is in orange. Third on Rolls would be the output of the macro.
Oldsheet:
Newsheet:
Rolls:
Untested, but this is how I'd do it. Just going from your screenshots. If your actual data looks different then you will need to make some adjustments.
Sub test()
Dim wb As Workbook, oldsht As Worksheet, newsht As Worksheet, rollsht As Worksheet
Dim c As Range, id, col, cDest As Range, copied As Boolean, m
Set wb = ThisWorkbook
Set oldsht = wb.Sheets("Insert Yesterday's Report Here")
Set newsht = wb.Sheets("Insert Today's Report Here")
Set rollsht = wb.Sheets("Rolls")
'next empty row on Rolls sheet
Set cDest = rollsht.Cells(Rows.Count, "A").End(xlUp).Offset(1)
'loop colA on new sheet
For Each c In newsht.Range("A2:A" & newsht.Cells(Rows.Count, "A").End(xlUp).row).Cells
id = c.Value 'identifier from Col A
If Len(id) > 0 Then
m = Application.Match(id, oldsht.Columns("A"), 0) 'check for exact match on old sheet
If Not IsError(m) Then
'got a match: check for updates in cols B to C
copied = False
For col = 2 To 3
If c.EntireRow.Cells(col).Value <> oldsht.Cells(m, col).Value Then
If Not copied Then 'already copied this row?
cDest.Resize(1, 3).Value = c.Resize(1, 3).Value 'copy changed row
Set cDest = cDest.Offset(1) ' next empy row
copied = True
End If
cDest.EntireRow.Cells(col).Interior.Color = vbRed 'flag updated value
End If
Next col
Else
cDest.Resize(1, 3).Value = c.Resize(1, 3).Value 'copy new row
Set cDest = cDest.Offset(1) ' next empy row
End If
End If
Next c
End Sub
I have a VBA script that currently matches Household IDs in two different worksheets (Children and Adults). If there is a match, the Adults worksheet is populated with the child's date of birth (DOB).
However, the adult can have multiple children and I need the all children's DOBs from the same household on separate consecutive columns in the adult's sheet depending on the number of children (Child DOB1, Child DOB2, etc.).
The VBA needs to be dynamic with no hard-coded column references since column locations can change. However, the column names (ex., Household ID) will always be the same.
It's also possible for more than one adult to be part of a household and I need each adult to have the same list of children DOBs.
Any suggestions would be much appreciated. I am limited in my VBA knowledge so any explanations or comments are helpful. Thank you!
Dim shtA As Worksheet
Dim shtC As Worksheet
Set shtA = ActiveWorkbook.Sheets("Adults")
Set shtC = ActiveWorkbook.Sheets("Children")
'Loop through heading row and get column number of "Household ID" column in "Adults" worksheet
'which will be used to match "Household ID" in the "Children" worksheet
Dim lastCol1 As Long
lastCol1 = shtA.Cells(1, Columns.Count).End(xlToLeft).Column
Dim hid1 As Long
Dim aa As Long
For aa = 1 To lastCol1
If LCase(shtA.Cells(1, aa).Value) = "household id" Then
hid1 = aa
Exit For
End If
Next aa
Dim lastCol As Long
lastCol = shtC.Cells(1, Columns.Count).End(xlToLeft).Column
Dim hid As Long
Dim dob As Long
Dim mm As Long
For mm = 1 To lastCol
If LCase(shtC.Cells(1, mm).Value) = "household id" Then
hid = mm
ElseIf LCase(shtC.Cells(1, mm).Value) = "dob" Then
dob = mm
End If
Next mm
'Begin populate new cols for Adults worksheet
Dim lastSRow As Long
Dim lastDRow As Long
Dim z As Long
Dim zz As Long
lastSRow = shtC.Cells(Rows.Count, 1).End(xlUp).Row 'get last row of source sheet
lastDRow = shtA.Cells(Rows.Count, 1).End(xlUp).Row 'get last row of destination sheet
'Would like to have all children in a household on separate columns in the "Adults" sheet
'Currently, only one child's DOB appears in one column named "Child DOB1"
'but I'd like subsequent columns, "Child DOB2", "Child DOB3", etc.
For z = 2 To lastDRow
For zz = 2 To lastSRow
If shtA.Cells(z, hid1).Value = shtC.Cells(zz, hid).Value Then
shtA.Cells(z, lastCol1 + 1).Value = shtC.Cells(zz, dob).Value
End If
Next zz
Next z
'add heading
shtA.Cells(1, lastCol1 + 1).Value = "Child DOB1"
You are missing a dynamic counter in your last netsted loops. Please try this code. I have taken the liberty and abstracted out getting column numbers in a function (one of the functions I almost always have in my applications).
Please note for this code to work, you have to add by hand "Child DOB1" in your Adults sheet.
Please also note how I saved the headings in a variant before looping: This helps the performance of the function. You can do something similar the rest of the code if you have large data.
Sub PopulateDOBs()
Dim shtA As Worksheet
Dim shtC As Worksheet
Set shtA = ActiveWorkbook.Sheets("Adults")
Set shtC = ActiveWorkbook.Sheets("Children")
Dim hid1 As Long
hid1 = GetColNo("household id", "Adults", 1)
Dim hid As Long
Dim dob As Long
hid = GetColNo("household id", "Children", 1)
dob = GetColNo("dob", "Children", 1)
'Begin populate new cols for Adults worksheet
Dim lastSRow As Long
Dim lastDRow As Long
Dim z As Long
Dim zz As Long
lastSRow = shtC.Cells(Rows.Count, 1).End(xlUp).Row 'get last row of source sheet
lastDRow = shtA.Cells(Rows.Count, 1).End(xlUp).Row 'get last row of destination sheet
Dim dob1Col As Long
Dim j As Long ' the missing counter I mentioned
dob1Col = GetColNo("Child DOB1", "Adults", 1)
For z = 2 To lastDRow
j = -1
For zz = 2 To lastSRow
If shtA.Cells(z, hid1).Value = shtC.Cells(zz, hid).Value Then
j = j + 1
shtA.Cells(z, dob1Col + j).Value = shtC.Cells(zz, dob).Value
'Add heading if missing
If shtA.Cells(1, dob1Col + j).Value <> "Child DOB" & (j + 1) Then
shtA.Cells(1, dob1Col + j).Value = "Child DOB" & (j + 1)
End If
End If
Next zz
Next z
End Sub
Function GetColNo(sHeading As String, sSheetName As String, lHeadingsRow As Long) As Long
Dim vHeadings As Variant
Dim lLastCol As Long
Dim j As Long
With ThisWorkbook.Sheets(sSheetName)
lLastCol = .Cells(lHeadingsRow, Columns.Count).End(xlToLeft).Column
vHeadings = .Range(.Cells(lHeadingsRow, 1), .Cells(lHeadingsRow, lLastCol)).Value
GetColNo = 0
For j = 1 To lLastCol
If LCase(vHeadings(1, j)) = LCase(sHeading) Then
GetColNo = j
Exit Function
End If
Next j
End With
End Function
Try this code using FIND rather than looking at each row/column. It also assumes that there's no Adult Household DOB columns present when starting.
Public Sub Test()
Dim Adult As Worksheet
Dim Children As Worksheet
Set Adult = ThisWorkbook.Worksheets("Adults")
Set Children = ThisWorkbook.Worksheets("Children")
'Find Household ID in Adult sheet.
With Adult.Rows(1)
Dim AdultHouseholdID As Range
Set AdultHouseholdID = .Find(What:="household id", After:=.Cells(1), LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
If AdultHouseholdID Is Nothing Then Exit Sub
'Find the last column in Adult sheet.
'This doesn't check if there's already DOB columns in the sheet.
Dim AdultLastColumn As Range
Set AdultLastColumn = .Cells(1, .Cells.Count).End(xlToLeft)
End With
With Children.Rows(1)
'Find Household ID in Children sheet.
Dim ChildHouseholdID As Range
Set ChildHouseholdID = .Find(What:="household id", After:=.Cells(1), LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
If ChildHouseholdID Is Nothing Then Exit Sub
'Find DOB column in Children sheet.
Dim ChildDOBColumn As Range
Set ChildDOBColumn = .Find(What:="DOB", After:=.Cells(1), LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
If ChildDOBColumn Is Nothing Then Exit Sub
End With
'Get the range of Adult Household IDs. The code will check each ID.
Dim AdultHouseHolds As Range
With Adult
Set AdultHouseHolds = .Range(AdultHouseholdID.Offset(1), .Cells(.Rows.Count, AdultHouseholdID.Column).End(xlUp))
End With
Dim HouseHold As Range
Dim FirstAddress As String
Dim DOBOffset As Long
Dim ChildDOB As Range
'Look at each Adult Household in turn.
For Each HouseHold In AdultHouseHolds
With Children.Columns(ChildHouseholdID.Column)
'Find the first DOB with corresponding Household ID.
Set ChildDOB = .Find(What:=HouseHold.Value, After:=.Cells(1), LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlNext)
If Not ChildDOB Is Nothing Then
'Remember the address - need to check for when FIND loops back around.
FirstAddress = ChildDOB.Address
DOBOffset = 1
Do
'Place the header - the Offset is reset for each Household ID.
Adult.Cells(1, AdultLastColumn.Column + DOBOffset) = "DOB" & DOBOffset
'Copy the Child DOB to the Adult sheet.
Children.Cells(ChildDOB.Row, ChildDOBColumn.Column).Copy _
Destination:=Adult.Cells(HouseHold.Row, AdultLastColumn.Column + DOBOffset)
DOBOffset = DOBOffset + 1
'Find the next value.
Set ChildDOB = .FindNext(ChildDOB)
Loop While ChildDOB.Address <> FirstAddress 'Keep going til it gets back to the first address.
End If
End With
Next HouseHold
End Sub
You're on the right lines.
What you really want your code to do is like this:
For each Child row (search by ID)
Find Matching Adult ID/s (by row)
Add that Child's DOB to the end of the relevant row.
(NB that I'm assuming the DOBs get put at the end of the row, rather than you inserting a dynamic amount of columns in the middle.)
Anyway, in code that would translate roughly to;
Dim LastCol As Integer, AdIDCol As Integer, ChIDcol As Integer, ChDOBCol as Integer
Dim shtA As Worksheet, shtC As Worksheet
Set shtA = ActiveWorkbook.Sheets("Adults")
Set shtC = ActiveWorkbook.Sheets("Children")
LastCol = ShtA.UsedRange.Columns.Count 'Children's DOBs will be put after this column.
'Identify relevant Columns in sheets - checking both sheets in one loop.
For a = 1 to Worksheetfunction.Max(LastCol, shtC.UsedRange.Columns.Count) 'This ensures that all of both sheets will be checked
If LCase(shtA.Cells(1,a).Value) = "household id" Then
AdIDCol = a
End If
If LCase(shtC.Cells(1,a).Value) = "household id" Then
ChIDCol = a
ElseIf LCase(shtC.Cells(1,a).Value) = "dob" Then
ChDOBCol = a
End If
Next a
'Now some nested loops to match children with adults
Dim AdultsFound as Integer 'this will be handy to speed up the loop
'First loop checks through children
For x = 2 to ShtC.UsedRange.Rows.Count
'Second loop checks through Adults
For y = 2 to ShtA.UsedRange.Rows.Count
If ShtC.Cells(x, ChIDCol).Value = ShtA.Cells(y, AdIDCol) Then
AdultsFound = AdultsFound + 1
'Third Loop checks to find what empty cell to copy the DOB into
z = Lastcol
Do While ShtA.Cells(y, z) <> ""
z = z+1 'moves to next column along
Loop
'Once found an empty cell in that row, copy the DOB to it
ShtC.Range(Cells(x, ChDOBCol), Cells(x, ChDOBCol)).Copy ShtA.Range(Cells(y,z), Cells(y,z))
End If
'If there are no more relevant adults in the sheet then stop searching for any more...
If AdultsFound = WorksheetFunction.Countif(ShtA.Cells(1, AdIDCol).EntireColumn, shtC.Cells(x, ChIDCol)) Then Exit For
Next y
Next x
Hope that helps?
Change the last lines of your code to something like this: (untested, but it should give you the idea)
Dim maxDOBColOffset As Long
For z = 2 To lastDRow
Dim DOBColOffset As Long
DOBColOffset = 1
For zz = 2 To lastSRow
If shtA.Cells(z, hid1).Value = shtC.Cells(zz, hid).Value Then
shtA.Cells(z, lastCol1 + DOBColOffset).Value = shtC.Cells(zz, dob).Value
DOBColOffset = DOBColOffset + 1
If maxDOBColOffset < DOBColOffsetThen
shtA.Cells(1, lastCol1 + DOBColOffset).Value = "Child DOB" & DOBColOffset
maxDOBColOffset = DOBColOffsetThen
End If
End If
Next zz
Next z
I have Sheet 1 (Column A ) value and Sheet 2 (Column A). I want to compare sheet 1 column A with sheet 2 Column A. If Sheet 1 (Column A) is found in the Sheet 2 then Delete the entire row in the Sheet 1. go to next one.
I have been stuck on this. Below is my Code. Its not working. Its keep getting wrong cell values
Sub Compare()
Dim i As Long
Dim j As Long
Dim lastRow_Task As Long
Dim lastRow_Compare As Long
Dim lastRow As Long
'Sheet 1
Dim Task As Worksheet
'Sheet 2
Dim Compare As Worksheet
Set Task = Excel.Worksheets("TaskDetails")
Set Compare = Excel.Worksheets("Compare")
Application.ScreenUpdating = False
lastRow_Task = Log.Cells(Rows.count, "A").End(xlUp).Row
lastRow_Compare = Compare.Cells(Rows.count, "A").End(xlUp).Row
For i = 2 To lastRow_Task
For j = 2 To lastRow_Compare
If Task.Cells(i, "A").Value = Compare.Cells(j, "A").Value Then
Compare.Cells(j, "A").ClearContents
End If
Next j
Next i
Using Match() is fast and will avoid the nested loop.
Also - when deleting rows it's best to work from the bottom to the top so the deleted rows don't interfere with your loop counter.
Sub Compare()
Dim i As Long
Dim lastRow_Task As Long
Dim Task As Worksheet 'Sheet 1
Dim Compare As Worksheet 'Sheet 2
Set Task = ActiveWorkbook.Worksheets("TaskDetails")
Set Compare = ActiveWorkbook.Worksheets("Compare")
Application.ScreenUpdating = False
lastRow_Task = Task.Cells(Task.Rows.Count, "A").End(xlUp).Row
For i = lastRow_Task To 2 Step -1
If Not IsError(Application.Match(Task.Cells(i, 1).Value, Compare.Columns(1), 0)) Then
Task.Rows(i).Delete
End If
Next i
Application.ScreenUpdating = True
End Sub
I realize there are a few different similar ideas on here. But I need help with this simple compare function.
My goal is to compare two different cells and if they are the same, replace it with its full non-abbreviated name.
Thank you for your time!!!
I.E
Sheet1 Sheet2
Column H Column A Column B
Dept Dept Department
This is what I have (Yes simple), but the cell H is not updating to the non-abbreviation:
Sub updateDeptNames()
'Format user ID from the email column
Dim ws As Worksheet, ws2 As Worksheet
Dim LastRow As Long, i As Long
Dim tmpArray() As String, tempDept As String
Set ws = ActiveWorkbook.Sheets("Student_Travel_DB") '--> This is the relevant sheet
Set ws2 = ActiveWorkbook.Sheets("gokoutd") '--> This is the relevant sheet
LastRow = 1000 ''Bug finding the last row, had to hard code it
For i = 2 To LastRow 'Iterate through all the rows in the sheet
For j = 2 To 112
tempDept = ws2.Range("A" & j).Value
If ws.Range("H" & i).Value = tempDept Then
ws.Range("H" & i) = ws2.Range("B" & j).Value
End If
Next j
Next i
End Sub
You can more easily use VLOOKUP either on your worksheet or with VBA:
Sub GetFullName()
Dim cl As Range, data As Range, lookUpRng As Range
Set data = Worksheets("Student_Travel_DB").Range("A1:A10")
Set lookUpRng = Worksheets("gokoutd").Range("A1:B10")
On Error Resume Next
For Each cl In data
cl = WorksheetFunction.VLookup(cl, lookUpRng, 2, False)
Next cl
End Sub
You'll need to change your range references.
I am currently using the Macro below for excel to move data from one one sheet to another. It is set up to fill from Row 2 down, as long as the rows are empty. I not want to have it already contain data in Columns 2 & 3. I have tried a number of things and am not having a lot of luck. I am new to this and "fixing" someone else's macro.
Sub MergeSheets()
Sheets("New").Activate
LastRowNew = Application.WorksheetFunction.CountA(Columns(1))
For i = 2 To LastRowNew
OrderNumber = Cells(i, 3)
Sheets("PRIOrders").Activate
LastRowPRI = Application.WorksheetFunction.CountA(Columns(1))
For j = 2 To LastRowPRI
If Cells(j, 3) = OrderNumber Then
Exit For
ElseIf j = LastRowPRI Then
Sheets("New").Rows(i).Copy Destination:=Sheets("PRIOrders").Rows(LastRowPRI + 1)
Sheets("PRIOrders").Rows(2).Copy
Sheets("PRIOrders").PasteSpecial xlPasteFormats
End If
Next
Sheets("New").Activate
Next
Sub MergeSheets()
Dim shtNew As Worksheet, shtOrders As Worksheet
Dim rngOrder As Range, rngNewOrders As Range
Dim f As Range, lastRow As Long
Set shtNew = ActiveWorkbook.Sheets("New")
Set rngNewOrders = shtNew.Range(shtNew.Range("C2"), _
shtNew.Cells(Rows.Count, 3).End(xlUp))
Set shtOrders = ActiveWorkbook.Sheets("PRIOrders")
For Each rngOrder In rngNewOrders.Cells
Set f = shtOrders.Columns(3).Find(Trim(rngOrder.Value), , xlValues, xlWhole)
If f Is Nothing Then
'find the last occupied row in Col B or C
lastRow = Application.Max(shtOrders.Cells(Rows.Count, 2).End(xlUp).Row, _
shtOrders.Cells(Rows.Count, 3).End(xlUp).Row)
rngOrder.EntireRow.Copy shtOrders.Cells(lastRow + 1, 1)
End If
Next rngOrder
End Sub