Why is my array returning empty? And how do I ensure it copies the data into my third selection - excel

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

Related

VBA code: report value in a selected column

for clarity, see pics and code
Hi,
Having these data:
Table 1 in "customers" sheet
Table 2 in "cars" sheet
I'm able to get the matching value of each row of "customers" to "cars" in a separate sheet "results".
However, I need to achieve 2 things:
Reporting in column A "results" sheet, the A column value of each respective row (therefore extracting this from the individual sheets of "customers" and "cars").
Having a similar table layout with headers denoting the respective columns of results
Col A= Customer/Inventory
Col B= Car
Col C= Color
Col D= Interior
I have been able to achieve up to this stage (pics) from the attached
Sub GenerateTable()
Dim selectedRows As Range
Set selectedRows = ThisWorkbook.Sheets("customers").Range("B2:D9")
Dim resultSheet As Worksheet
On Error Resume Next
Set resultSheet = ThisWorkbook.Sheets("results")
On Error GoTo 0
If resultSheet Is Nothing Then
Set resultSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
resultSheet.Name = "results"
End If
resultSheet.Cells.Clear
Dim carsSheet As Worksheet
Set carsSheet = ThisWorkbook.Sheets("cars")
Dim carsRange As Range
Set carsRange = carsSheet.Range("B2:D13")
Dim rng As Range
Dim row As Range
Dim found As Range
Dim match As Boolean
Dim lastRow As Long
For Each row In selectedRows.Rows
match = False
For Each rng In carsRange.Rows
If row.Cells(1, 1) = rng.Cells(1, 1) And row.Cells(1, 2) = rng.Cells(1, 2) And row.Cells(1, 3) = rng.Cells(1, 3) Then
If match = False Then
lastRow = resultSheet.Cells(Rows.Count, 1).End(xlUp).row + 1
row.Copy resultSheet.Cells(lastRow, 1)
match = True
End If
rng.Copy resultSheet.Cells(lastRow + 1, 1)
lastRow = lastRow + 1
End If
Next rng
Next row
End Sub
Cars
result:

VBA - Loop through and copy/paste value on range based on different cell value

I have been struggling with this code. I want to loop through Column E beginning with E5, on the Sheet titled "pivot of proposal" (which is a pivot table); and every time it finds a cell with the value of "check" I want it to copy/paste value of cells A & B of the corresponding row to the sheet titled Check Payments in E & F, moving down a row each time but beginning on row 4. I tried to piece together other bits of code but it is not doing what I need it to.
Sub Loop_Check_Payments()
Dim c As Range
Dim IRow As Long, lastrow As Long, krow as long
Dim copyrow As Integer
Dim rSource As Range
Dim DataOrigin As Worksheet, DataDest As Worksheet, DataDestACH As Worksheet
On Error GoTo Whoa
'~~> Sheet Where "L" needs to be checked
Set DataOrigin = ThisWorkbook.Sheets("Pivot of proposal")
'~~> Output sheet
Set DataDest = ThisWorkbook.Sheets("CHECK PAYMENTS")
Set DataDestACH = ThisWorkbook.Sheets("ACH_WIRE PAYMENTS CASH POOLER")
Application.ScreenUpdating = False
'~~> Set you input range
Set rSource = Range("Payment_Method")
'~~> Search for the cell which has "L" and then copy it across to sheet1
For Each c In rSource
If c.Value = "Check" Then
DataDest.Cells(4 + IRow, 5) = DataOrigin.Cells(c.Row, 1)
DataDest.Cells(4 + IRow, 6) = DataOrigin.Cells(c.Row, 2)
IRow = IRow + 1
Else
DataDestACH.Cells(4 + kRow, 7) = DataOrigin.Cells(c.Row, 1)
DataDestACH.Cells(4 + kRow, 8) = DataOrigin.Cells(c.Row, 2)
kRow = kRow + 1
End If
Next c
Whoa:
MsgBox Err.Description
End Sub
Instead of trying to Copy/paste - you can do something like this (as PeterT alluded to in comments)
this will put values from columns A&B (ordinal 1 & 2) of the SOURCE to the same row/column in the destination:
If c.Value = "Check" Then
DataDest.Cells(c.Row, 1) = DataOrigin.Cells(c.Row, 1)
DataDest.Cells(c.Row, 2) = DataOrigin.Cells(c.Row, 2)
End If

copy, paste, transpose rows with pictures

I have a macro that copies and pastes rows from input sheet to output sheet. I find PRODUCT NAME and END DATE, then copy the whole row and transpose when pasting it. I am using transpose because I want to have vertical table.
I have a problem with images because I don't know how to copy them to proper cell so they match with Name and Date. I've managed to write a script that is copying and pasting images but it puts all of them in cell A1. When I want to add range to target_sheet.Paste I am getting vba method intersect of object _application failed error.
Below you can see how input and output sheets look.
Input sheet:
Expected output sheet (with only 3 columns) :
It is very important to know that 'input' sheet contains many products with names, prices and images and there is always a blank row between them. The number of images in each row can be different (from 1 to 25).
Sub copy_paste()
Dim Cell As Range
Dim src_rng As String
Dim LR As Long
Dim source_sheet As Worksheet
Dim target_sheet As Worksheet
Dim pic As Shape
'worksheet with source data
Set source_sheet = ThisWorkbook.Sheets("input")
'worksheet with newly created template
Set target_sheet = ThisWorkbook.Sheets("output")
'range of cells I want to check
src_rng = "A14:A26"
Application.ScreenUpdating = False
target_sheet.Cells.Delete
'copy paste, transpose product line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("A10000").End(xlUp).Row + 1
If Cell.Value = "Name" Then
Cell.EntireRow.Copy
target_sheet.Range("A" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Next
'copy paste, transpose end line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("B10000").End(xlUp).Row + 1
If Cell.Value = "Date" Then
Cell.EntireRow.Copy
target_sheet.Range("B" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Next
'copy paste image
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("C10000").End(xlUp).Row + 1
If Cell.Value = "Image" Then
For Each pic In source_sheet.Shapes
If Not Application.Intersect(pic.TopLeftCell, Range(src_rng)) Is Nothing Then
pic.CopyPicture
target_sheet.Paste
End If
Next pic
End If
Next
Application.ScreenUpdating = True
End Sub
Please, try the next code. It follows the logic deduced from your last question edit, respectively: the former "Name" becomes "Product Name", "Date" becomes "End Date" and the row keeping the pictures is the one below "Product Name" row. It is able to process two or three product names/pictures per group:
Sub copy_paste()
Dim Cell As Range, src_rng As String, LR As Long
Dim source_sheet As Worksheet, target_sheet As Worksheet
Dim pic As Shape, arrPAddr, rngTr As Range, k As Long
Dim cellRHeight As Range, nrShapesPerRange As Long 'to be 2 or 3
nrShapesPerRange = 2 'Choose here initial number of shapes per row (2 or 3)
'worksheet with source data
Set source_sheet = ThisWorkbook.Sheets("input")
'worksheet with newly created template
Set target_sheet = ThisWorkbook.Sheets("output")
'range of cells I want to check
src_rng = "A14:A26"
Application.ScreenUpdating = False
ReDim arrPAddr(1 To 2, 1 To source_sheet.Shapes.count): k = 1
target_sheet.cells.Delete: For Each pic In target_sheet.Shapes: pic.Delete: Next
'copy paste, transpose product line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("A" & rows.count).End(xlUp).row + 1
If Cell.value = "Product Name" Then
source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
Set rngTr = target_sheet.Range("A" & LR)
rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
arrPAddr(1, k) = Cell.Offset(1, 1).Address
arrPAddr(2, k) = rngTr.Offset(, 2).Address: k = k + 1
arrPAddr(1, k) = Cell.Offset(1, 2).Address
arrPAddr(2, k) = rngTr.Offset(1, 2).Address: k = k + 1
If nrShapesPerRange = 3 Then
arrPAddr(1, k) = Cell.Offset(1, 3).Address
arrPAddr(2, k) = rngTr.Offset(2, 2).Address: k = k + 1
End If
If cellRHeight Is Nothing Then Set cellRHeight = Cell.Offset(1)
End If
LR = target_sheet.Range("B" & rows.count).End(xlUp).row + 1
If Cell.value = "End Date" Then
source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
Set rngTr = target_sheet.Range("B" & LR)
rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
End If
Next
ReDim Preserve arrPAddr(1 To 2, 1 To k - 1)
'Making the row height in target_sheet equal to source_sheet column with:
target_sheet.Range("2:" & LR + 3).EntireRow.RowHeight = source_sheet.Range("A16").EntireRow.RowHeight
target_sheet.Range("A:C").EntireColumn.AutoFit
target_sheet.Range("C1").EntireColumn.ColumnWidth = cellRHeight.EntireColumn.ColumnWidth
'copy paste image:
Dim i As Long
For Each pic In source_sheet.Shapes
For i = 1 To UBound(arrPAddr, 2)
If pic.TopLeftCell.Address = arrPAddr(1, i) Then
pic.Copy: target_sheet.Paste
With target_sheet.Shapes(target_sheet.Shapes.count)
.top = target_sheet.Range(arrPAddr(2, i)).top + (target_sheet.Range(arrPAddr(2, i)).RowHeight - pic.height) / 2
.left = target_sheet.Range(arrPAddr(2, i)).left
End With
Exit For
End If
Next i
Next
Application.ScreenUpdating = True
target_sheet.Activate
MsgBox "Ready..."
End Sub
Plese, test the code and send some feedback

Color cells if same value found in a specified column

The following VBA code colors the cells in column B if the same value appears within column D.
I would like to also color column C. Changing the range to "B:D" does not work.
Sub HighlightCellIfValueExistsinAnotherColumn()
Dim ws As Worksheet
Dim x As Integer
Dim Find As Variant
Set ws = Worksheets("Sheet5")
For x = 1 To ws.Range("B" & Rows.Count).End(xlUp).Row
Set Find = ws.Range("D:D").Find(What:=ws.Range("B" & x).Value, LookAt:=xlWhole)
If Not Find Is Nothing Then
If ws.Cells(Find.Row, 6).Value = 0 And ws.Cells(Find.Row, 9).Value = 0 Then
ws.Range("B" & x).Interior.ColorIndex = 6
End If
End If
Next x
End Sub
Just duplicate the same command:
...
ws.Range("B" & x).Interior.ColorIndex = 6
ws.Range("C" & x).Interior.ColorIndex = 6
...
Add the D column if you wish.
EDIT:
I made adjustments to your code and annotate them to explain what the code means.
I used ListObjects/Table since that is what you have given as an example. In my testing, the code highlighted A-C columns on rows 2 and 5 only.
Sub HighlightCellIfValueExistsinAnotherColumn()
Dim ws As Worksheet
Dim nRow, sourceCol, findCol As Long
Dim FoundCell As Variant
Dim lo As ListObject
Dim LookupValue As String
Set ws = Worksheets("Sheet1")
'Note: set a table name for your entire table range
'I assumed "Table1" as its name so it is arbitrary
Set lo = ws.ListObjects("Table1")
'column to iterate
sourceCol = lo.ListColumns("List2").Index
'column to search
findCol = lo.ListColumns("Animals").Index
'for each row of the list object
For nRow = 1 To lo.ListRows.Count
'what value to search
LookupValue = lo.DataBodyRange.Cells(nRow, sourceCol)
'try to find the value and return the cell
Set FoundCell = lo.DataBodyRange.Columns(findCol).Find(LookupValue, LookAt:=xlWhole)
'if value is found
If Not FoundCell Is Nothing Then
'check colums 6 and 9 if zero
If ws.Cells(FoundCell.Row, 6).Value = 0 And ws.Cells(FoundCell.Row, 9).Value = 0 Then
'color em yellow "List1", "List2" & "List3" for the current row
lo.DataBodyRange.Cells(nRow, sourceCol).Interior.ColorIndex = 6
lo.DataBodyRange.Cells(nRow, sourceCol + 1).Interior.ColorIndex = 6
lo.DataBodyRange.Cells(nRow, sourceCol - 1).Interior.ColorIndex = 6
End If
End If
Next nRow
End Sub

Array not printing to second row of my second worksheet?

I'll just provide snippets. Basically I have two sets of data on a master roster, and they're divided by an X value in column H of the roster. I want X's to be printed to Sheet1 of Wb and Blanks to be printed to Sheet2.
I have it working, but since it declares FinalDest as a singular variable, it doesn't start on row 2 of the Sheet2.
Example: if X's fill to row 10 of Sheet1, it will start Sheet2's data on row 11 instead of 2 (after headers).
Sub Main()
Dim Wb As Workbook
Dim Data, Last, Login, SaveTyping
Dim i As Long, j As Long, k As Long, a As Long
Dim Dest1 As Range, Dest2 As Range, FinalDest As Range
Set Wb = Workbooks("Template.xlsx")
Set Dest1 = Wb.Sheets("Currently Eligible").Range("A2")
Set Dest2 = Wb.Sheets("Newly Eligible").Range("A2")
With ThisWorkbook.Sheets("Roster")
Data = .Range("AA2", .Range("A" & Rows.Count).End(xlUp))
End With
After I declare my array, this is how I separate what's printed to the template.
SaveTyping = Data(i, 8) 'Column my X's and Blanks are
If InStr(SaveTyping, "X") Then
Set FinalDest = Dest1
End If
If SaveTyping = "" Then
Set FinalDest = Dest2
End If
For k = 1 To UBound(Data, 2)
FinalDest.Offset(j, a) = Data(i, k) 'Where I need to tell array to print
a = a + 1
Next
j = j + 1
Next
FinalDest range picks up on the next row after where it left off from Sheet1, how do I prevent that and have it start on Row 2 for both sheets?
Option Explicit
Sub Main()
Dim Wb As Workbook 'Workbook I'm printing each managers employee roster to and saving off a copy to a folder
Dim Data, Last, Login, chkVal 'Data = data I'm printing into template / Last = Manager name / Login = Manager Login ID
Dim i As Long, j As Long, k As Long, a As Long 'i = Data(row) / k = Data(column) / a = Wb(row) / j = Wb(column)
Dim Dest1 As Range, Dest2 As Range, FinalDest As Range 'Dest1 = Sheets(1) of Wb / Dest2 = Sheets(2) of Wb
Set Wb = Workbooks("Template.xlsx") 'Sets template for each file cut
Set Dest1 = Wb.Sheets("Currently Eligible").Range("B2")
Set Dest2 = Wb.Sheets("Newly Eligible").Range("B2")
With ThisWorkbook.Sheets("Sheet1")
Data = .Range("AA2", .Range("A" & Rows.Count).End(xlUp)) 'Raw data
End With
Wb.Activate
Application.ScreenUpdating = False
For i = 1 To UBound(Data) 'Row 1 to Ubound of Data(rows)
If Data(i, 1) <> Last Then 'only print array to Wb one manager at a time, we see when managers change because values in Data(i,1) will <> the next cell
If i > 1 Then 'skip header
Wb.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & _
ValidFileName(Login & " - " & Last & " - Shift Differential Validation.xlsx")
End If
With Sheets("Exempt Population")
.Rows(2 & ":" & .Rows.Count).ClearContents 'Clears previous managers data
End With
Last = Data(i, 1) 'Manager last name is in Column A
chkVal = Data(i, 8) 'Check for X or Blank in Column H
Login = Data(i, 27) 'Manager login ID is in column AA
j = 0 'Wb Column = 0
End If
a = 0 'Wb Row = 0
SaveTyping = Data(i, 8) 'Column my X's and Blanks are
If InStr(SaveTyping, "X") Then
Set FinalDest = Dest1
End If
If SaveTyping = "" Then
Set FinalDest = Dest2
End If
For k = 1 To UBound(Data, 2) 'Column 1 to Ubound of Data(columns)
FinalDest.Offset(j, a) = Data(i, k)
a = a + 1 'next Wb row
Next
j = j + 1 'next Wb column
Next
SaveCopy Wb, Login, Last '<< save the last report
End Sub
I cleaned up the code a bit, giving proper names to indexes.
In terms of a solution to your issue, I added two different row indices, one for X one for blank. Depending on whether its an X or blank, you increment either the one or the other.
Option Explicit
Sub Main()
Dim Wb As Workbook 'Workbook I'm printing each managers employee roster to and saving off a copy to a folder
Dim Data, Last, Login, chkVal 'Data = data I'm printing into template / Last = Manager name / Login = Manager Login ID
Dim row_data As Long, col_wb As Long, col_data As Long, row_wb As Long
Dim Dest1 As Range, Dest2 As Range, FinalDest As Range 'Dest1 = Sheets(1) of Wb / Dest2 = Sheets(2) of Wb
Dim row_index_x As Long, row_index_blank As Long, isX As Long
Set Wb = Workbooks("Template.xlsx") 'Sets template for each file cut
Set Dest1 = Wb.Sheets("Currently Eligible").Range("B2")
Set Dest2 = Wb.Sheets("Newly Eligible").Range("B2")
With ThisWorkbook.Sheets("Sheet1")
Data = .Range("AA2", .Range("A" & Rows.Count).End(xlUp)) 'Raw data
End With
Wb.Activate
Application.ScreenUpdating = False
' initialise row indices to 0, ignore header as Dest1 and Dest2 already at B2.
row_index_x = 0
row_index_blank = 0
For row_data = 1 To UBound(Data) 'Row 1 to Ubound of Data(rows)
' if manager name changed between this row and previous row
If Data(row_data, 1) <> Last Then 'only print array to Wb one manager at a time, we see when managers change because values in Data(row_data,1) will <> the next cell
If row_data > 1 Then 'skip header
' save wb every time manager changes
Wb.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & _
ValidFileName(Login & " - " & Last & " - Shift Differential Validation.xlsx")
End If
With Sheets("Exempt Population")
.Rows(2 & ":" & .Rows.Count).ClearContents 'Clears previous managers data
End With
Last = Data(row_data, 1) 'Manager last name is in Column A
chkVal = Data(row_data, 8) 'Check for X or Blank in Column H
Login = Data(row_data, 27) 'Manager login ID is in column AA
' reset output row every time manager name changes
row_wb = 0 'Wb Row = 0
End If
' for every data row, reset output column to zero (start a new row)
col_wb = 0 'Wb Col = 0
SaveTyping = Data(row_data, 8) 'Column my X's and Blanks are
' decide output destination
If InStr(SaveTyping, "X") Then
Set FinalDest = Dest1
row_wb = row_index_x
isX = 1 ' remember whether its X or blank
End If
If SaveTyping = "" Then
Set FinalDest = Dest2
row_wb = row_index_blank
isX = 0
End If
' Loop through all columns for one row of data
' keep output row the same, increase the output column
For col_data = 1 To UBound(Data, 2) 'Column 1 to Ubound of Data(columns)
FinalDest.Offset(row_wb, col_wb) = Data(row_data, col_data)
col_wb = col_wb + 1 'next Wb column
Next
'row_wb = row_wb + 1 'next Wb row
' decide which row index to increase
If isX = 1 Then
row_index_x = row_index_x + 1
Else
row_index_blank = row_index_blank + 1
End If
Next
SaveCopy Wb, Login, Last '<< save the last report
End Sub

Resources