I have been trying so hard. I cant figure this out. I am working with two sheets. One sheet searches for a criteria "RR", ir there is an RR, it assigns a variable a serial to be searched in another sheet. If the serial is found in the other sheet, I would like to determine the row where it is located and assign it to a variable. "DidTransfer = Sheets(PreviousTabName).Range("B" & thiscell.Row).Value" The problem when I use thiscell.Row, its giving me so many problems. I need the row number to so I can reference the same row to get information from another cell on the same row. Please help.
Sub TempModifier()
Dim NYSID, PLookUpTabRange, IsRR, DidTransfer As String
Dim thiscell As Range
'Variable for Temp
Dim TempFirstRow As Integer
Dim TempLastRow As Long
'Variables for the previous
Dim PreviousTabLastRow As Long
Dim PreviousTabFirstRow As Integer
'Initialize the temp variables
TempLastRow = Sheets("Temp").Range("D" & Rows.Count).End(xlUp).Row
PreviousTabName = "February"
PreviousTabFirstRow = 7
With Sheets(PreviousTabName)
PreviousTabLastRow = .Cells(256, "H").End(xlUp).Row 'Get the last row in the data range
End With
'Create a data-range variable
PLookUpTabRange = "H" & PreviousTabFirstRow & ":" & "H" & PreviousTabLastRow
'Begin looping structure to copy data from the temp tab to the current tab
For TempFirstRow = 2 To TempLastRow
'Assign the value of the housing unit
IsRR = Sheets("Temp").Cells(TempFirstRow, 2).Value
'Check if the value is RR
If IsRR = "RR " Then
'If the value is RR, then get the NYSID
NYSID = Worksheets("Temp").Cells(TempFirstRow, 4).Value
If Not IsError(Application.Match(NYSID, Worksheets(PreviousTabName).Range(PLookUpTabRange), 0)) Then
'NYSID is Found on Current Month Sheet, do Nothing
Else
DidTransfer = ""
Set thiscell = Sheets(PreviousTabName).Columns("D").Find(What:=NYSID, LookIn:=xlValues, lookat:=xlWhole)
DidTransfer = Sheets(PreviousTabName).Range("B" & thiscell.Row).Value
Select Case DidTransfer
Case "Transferred"
DidTransfer = "Transferred"
Case Else
DidTransfer = DidTransfer
End Select
If IsError(Application.Match(NYSID, Worksheets(PreviousTabName).Range(PLookUpTabRange), 0)) Or _
(Not IsError(Application.Match(NYSID, Worksheets(PreviousTabName).Range(PLookUpTabRange), 0)) And _
DidTransfer = "Transferred") Then
'Worksheets("Temp").Rows(TempFirstRow).Delete
MsgBox "Delete"
End If
End If
End If
'Go to the next row
Next TempFirstRow
End Sub
Related
I'm trying to figure out the best way to attack this problem and my head is spinning a bit, I'm not sure if I should use For Each Cell or Arrays or Collections to do some comparisons and copy entire rows to new sheets. I'd like to use Arrays but my code only uses the values of column but then I have to go back and re-loop through column to find "missing values" and copy entire row which seems to defeat part of the point of using arrays (speed/efficiency).
I'm looking for advice on the best way to tackle this issue, but I'll post my array code as well.
First off, example data:
Sheet1:
Sheet2:
The idea is Sheet1 is yesterdays report and sheet2 is todays.
My goal is two more sheets (or one combo sheet, but that seems unnecessary hard as I need to do total calculations on each result sheet search results respectively by totaling one of the columns, but not the value in column A)
ItemsAdded:
A6 AV6
ItemsRemoved:
A5 AV5
So basically it is finding what items where removed and what was added comparing sheet2 to sheet1 column A.
So far I was able to get that part, without the row values and I'm really wondering if I'm attacking this correctly.
IE: This gets the missing/added items. Now I need to go and fetch the entire row for the values in each sheet, but am unsure how and the code is starting to look long and repeating.
Public Function RangeToArray(Rng As Range) As Variant
Dim i As Long, r As Range
ReDim arr(1 To Rng.Count)
i = 1
For Each r In Rng
arr(i) = r.Value
i = i + 1
Next r
RangeToArray = arr
End Function
Public Sub Compare_Columns_A_and_B_with_Arrays()
Dim wb As Workbook, wsA As Worksheet, wsB As Worksheet, Missing As Worksheet, Added As Worksheet
Set wb = ActiveWorkbook
Set wsA = wb.Worksheets("Sheet1")
Set wsB = wb.Worksheets("Sheet2")
Set Missing = wb.Worksheets("Missing")
Set Added = wb.Worksheets("Added")
Dim lRowA As Long
lRowA = wsA.Cells(Rows.Count, 1).End(xlUp).Row
Dim sourceArray As Variant, srcrng As Range
Set srcrng = wsA.Range("A1:A" & lRowA)
sourceArray = RangeToArray(srcrng)
Dim lRowB As Long
lRowB = wsB.Cells(Rows.Count, 2).End(xlUp).Row
Dim verifyArray As Variant, verifyrng As Range
Set verifyrng = wsB.Range("A1:A" & lRowB)
verifyArray = RangeToArray(verifyrng)
For Each arrval In sourceArray
IsInArray = (UBound(Filter(verifyArray, arrval)) > -1)
If IsInArray = False Then
'Debug.Print arrval
Dim lRowMissing As Long
lRowMissing = Missing.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
Missing.Range("A" & lRowMissing).Value = arrval
End If
Next arrval
For Each arrval In verifyArray
IsInArray = (UBound(Filter(sourceArray, arrval)) > -1)
If IsInArray = False Then
'Debug.Print arrval
Dim lRowAdded As Long
lRowAdded = Added.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
Added.Range("A" & lRowAdded).Value = arrval
End If
Next arrval
End Sub
Assuming that you want to achieve something like this:
In a Sheet1 and Sheet2 there are headers (in my case i've used Header 1 and Header 2.
In a result sheet:
Yesterday column holds an information about count of A(x) data in Sheet1.
Today column holds an information about count of A(x) data in Sheet2.
I have used below code:
Option Explicit
Sub CompareData()
Dim wbk As Workbook
Dim wshYesterday As Worksheet, wshToday As Worksheet, wshResult As Worksheet
Dim i As Integer, j As Integer, k As Integer
On Error Resume Next
Set wbk = ThisWorkbook
Set wshResult = wbk.Worksheets("Result")
On Error GoTo Err_CompareData
If Not wshResult Is Nothing Then
Application.DisplayAlerts = False
wbk.Worksheets("Result").Delete
Application.DisplayAlerts = True
End If
Set wshYesterday = wbk.Worksheets("Sheet1")
Set wshToday = wbk.Worksheets("Sheet2")
Set wshResult = wbk.Worksheets.Add(After:=wshToday)
wshResult.Name = "Result"
wshResult.Range("A1") = "Header 1"
wshResult.Range("B1") = "Header 2"
wshResult.Range("C1") = "Yesterday"
wshResult.Range("D1") = "Today"
'find last entry in yesterdays data
i = wshYesterday.Range("A" & wshYesterday.Rows.Count).End(xlUp).Row
j = 2
'copy into result sheet
wshYesterday.Range("A2:B" & i).Copy wshResult.Range("A" & j)
j = j + i - 1
'find last entry in todays data and copy into result sheet
i = wshToday.Range("A" & wshToday.Rows.Count).End(xlUp).Row
wshToday.Range("A2:B" & i).Copy wshResult.Range("A" & j)
'remove duplicates
i = wshResult.Range("A" & wshResult.Rows.Count).End(xlUp).Row
wshResult.Range("A2:B" & i).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
j = 2
i = wshResult.Range("A" & wshResult.Rows.Count).End(xlUp).Row
Do While j <= i
'count values stored in column #1 in yesterdays data
k = Application.WorksheetFunction.CountIf(wshYesterday.UsedRange, wshResult.Range("A" & j))
wshResult.Range("C" & j) = k
'count todays data
k = Application.WorksheetFunction.CountIf(wshToday.UsedRange, wshResult.Range("A" & j))
wshResult.Range("D" & j) = k
j = j + 1
Loop
Exit_CompareData:
On Error Resume Next
Set wshYesterday = Nothing
Set wshToday = Nothing
Set wshResult = Nothing
Set wbk = Nothing
Exit Sub
Err_CompareData:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_CompareData
End Sub
Feel free to improve it to your needs.
Hard to know exactly what you want, but here is a Power Query solution (available in Excel 2010+) that creates a table summarizing what's been removed and/or added.
I assumed your data was in tables named Yesterday and Today. Change the table names in the Source = lines to match your real data.
M-Code
let
//Read in the data tables
Source = Excel.CurrentWorkbook(){[Name="Yesterday"]}[Content],
Yesterday = Table.TransformColumnTypes(Source,{{"Column1", type text}, {"Column2", type text}}),
Source2 = Excel.CurrentWorkbook(){[Name="Today"]}[Content],
Today = Table.TransformColumnTypes(Source2,{{"Column1", type text}, {"Column2", type text}}),
/*Using the appropriate JoinKind, create two different tables for
itemsAdded and itemsRemove*/
itemsAddedTBL = Table.NestedJoin(Today,"Column1",Yesterday,"Column1","TBL",JoinKind.LeftAnti),
//Remove the unneeded TBL column
itemsAdded = Table.RemoveColumns(itemsAddedTBL,"TBL"),
//Add a column stating "Added"
itemsAddedLBL = Table.AddColumn(itemsAdded,"Add/Remove", each "Added", type text),
//Repeat the above for removed items
itemsRemovedTBL = Table.NestedJoin(Yesterday,"Column1",Today,"Column1","TBL",JoinKind.LeftAnti),
itemsRemoved = Table.RemoveColumns(itemsRemovedTBL,"TBL"),
itemsRemovedLBL = Table.AddColumn(itemsRemoved, "Add/Remove", each "Removed",type text),
//combine (append) the two tables into one
comb = Table.Combine({itemsAddedLBL,itemsRemovedLBL})
in
comb
I actuallaly ended up using #AceErno's comment and using AutoFilter to pull the EntireRows of the data that was found by comparing arrays using the code in my original question. I'm not sure happy with my code, but it works and I can look into that later when I am feeling up for it.
I have excel workbook and i need to compare column B and column W if column B & W data is the same need to copy an entire row to a newsheet(sheetname "Reconciled") column B data is date format like this (2020-02-01 07:55:08.0) column W date format is like this (27/01/2020) Column B & W need to compare with the date.
this code date is selected but it is working but it is wrong.
Sub runThrough(cbpath As String, bspath As String)
Dim newcashBook, newbankstmt As Worksheet
Dim cashbook, Bankstmt As Workbook
Dim i, j As Long
Dim cbRecords, bsRecords rng As String
Set cashbook = Workbooks.Open(cbpath)
'copy data from another workbook
Set newcashBook = cashbook.Sheets(1)
newcashBook.Range("A1:Z1048576").Copy
cashbook.Close
'paste data to W1 row from another workbook
Set newbankstmt = ThisWorkbook.Sheets("Sheet0")
newbankstmt.Range("W1").PasteSpecial
For i = 2 To 100
Set newbankstmt = ThisWorkbook.Sheets("Sheet0")
' Sheet0 is activeworkbook active worksheet
Rows.Cells(i, 2).Select
Rows.Cells(i, 2).Select
For j = 2 To 100
Rows.Cells(j, 31).Select
If (i = j) Then
Debug.Print "yes" 'check data same or not
Else
Debug.Print "wrong"
End If
Next j
Next i
End Sub
The below check if both date are valid and check if there are the same. Modify and use:
Sub populate_sales()
Dim bDate As Date, wDate As Date
With ThisWorkbook.Worksheets("Sheet1")
'Check if both date are valid
If IsDate(.Range("B1").Value) And IsDate(.Range("W1").Value) Then
bDate = Year(.Range("B1").Value) & "-" & Right("0" & Month(.Range("B1").Value), 2) & "-" & Right("0" & Day(.Range("B1").Value), 2)
wDate = Year(.Range("W1").Value) & "-" & Right("0" & Month(.Range("W1").Value), 2) & "-" & Right("0" & Day(.Range("W1").Value), 2)
If bDate = wDate Then
'Copy
End If
Else
MsgBox "Invalid dates"
End If
End With
End Sub
I prepared a code based on what I could deduce from your question and comments. So, the code copy, as fast as possible (using array) the content of cashbook.Sheets(1) in newbankstmt.Range("W1").
Then it iterates between 100 rows and, if "B" cell Date on a specific row is equal with the "W" cell Date of the same row, then the rage "A:W" address of the respective row is returned in Immediate Window and the code is stopped. You can go to the next such occurrence pressing F5. In order to see the returned value in Immediate Window, you must press Ctrl + G.
If this is what you needed, please confirm and I will show you how that ranges can be also loaded in another array and paste at once in a new sheet, or wherever you need, if clearly explain where...
This code doesn't care about the cell (date) format. But, the code would work only if both cells in discussion (B and W) are of Date type.
Sub runThrough(cbpath As String, bspath As String)
Dim newcashBook As Worksheet, newbankstmt As Worksheet
Dim cashbook As Workbook, Bankstmt As Workbook
Dim i As Long, dateB As Date, dateW As Date, arrC As Variant
Set cashbook = Workbooks.Open(cbpath)
'copy data from cashbook:
Set newcashBook = cashbook.Sheets(1)
'input the big range in arrC array:
arrC = newcashBook.Range("A1:Z1048576").value
cashbook.Close
'copy the arrC content starting from W1:
Set newbankstmt = ThisWorkbook.Sheets("Sheet0")
newbankstmt.Range("W1").Resize(UBound(arrC, 1), UBound(arrC, 2)).value = arrC
For i = 2 To 100 'why To 100?
dateB = newbankstm.Cells(i, "B").value
dateW = newbankstm.Cells(i, "W").value
If DateSerial(Year(dateB), Month(dateB), Day(dateB)) = DateSerial(Year(dateW), Month(dateW), Day(dateW)) Then
Debug.Print "Range to be copied: " & newbankstm.Range(newbankstm.Cells(i, 1), _
newbankstm.Cells(i, "W")).Address
Stop
End If
Next i
End Sub
I've seen some questions answered about creating tables in word from excel but they don't quite have what I'm looking for. I have an excel sheet that has the details on equipment (company #, serial #, manufacturer, description, and model #). This file currently has 17114 rows of equipment data. I have a word doc with four columns (quantity, company #, part #, description).
Right now on excel I have a button to open up the word doc and another that brings up a userform. The user form has a combo box and a text bot. The combo box chooses what column in excel to search in. The text box is what the person is looking for. The code for this is below
Dim myLastRow As Long
Dim myResult As Long
Dim myTableRange As Range
myLastRow = Cells(Rows.Count, 1).End(xlUp).Row
If ComboBox1.Value = "Serial" Then
Set myTableRange = Range("B1:B" & myLastRow)
myResult = Application.Match(TextBox1.Value, myTableRange, 0) 'Returns row number only
Range("B" & myVLookupResult).Activate
ElseIf ComboBox1.Value = "MII" Then
Set myTableRange = Range("A1:A" & myLastRow)
myResult = Application.Match(TextBox1.Value, myTableRange, 0) 'Returns row number only
Range("A" & myResult).Activate
Else
MsgBox ("No Range Selected")
End If
Where "MII" is the company #. This code is placed on a command button. From here I want the macro to copy the data from myResult over to word. The cells to copy would be
Cells(myResult, 1)
to the second column in word;
Cells (myResult, 2)
to the third column in word; and
Cells(myResult, 3) & ", " & Cells(myResult, 4) & ", Model #" & Cells(myResult, 5)
to the 4th column in word. I am also looking for word to check where the first blank row is (after the headers) and insert these there. And if there are no blank rows before the footer (also part of the table) to add a row.
The default number of rows I can put the data is 16. With 13 rows for the header (header is part of the table). A total of 19 rows will create a second page but without any cells on the second page for data (only the header and footer). It isn't until 28 rows are made that cells for data start popping up on page 2.
My questions are how do I reference specific cells in a table in word? Can I use the same code for finding the first blank cell after the header as I would in excel? Would the code also be the same for adding rows to the table and counting the available rows to make sure I'm typing on the right page?
Right now all I have for the word side of the macro is calling the document up.
Dim objWord, objDoc As Object
Set objWord = GetObject(, "Word.Application")
objWord.Visible = True
I know I can use something similar as below but that doesn't specify where to put the data.
Sheets(1).Range(FirstCell, LastCell).Copy
objWord.Selection.Paste
objWord.Selection.TypeParagraph
I still haven't figured out how to add rows automatically. I keep getting run-time error '5991': Cannot access individual rows in this collection because the table has vertically merged cells. (Edit: I found out I didn't have the Microsoft Word Object Library reference clicked. After doing this other answers to this question worked.)
Since what I have done is still a decent time saver for me and might help other people trying to do the same thing I'm going to post what I have so far. Note: there's still some unused code in there from trying out stuff to see if it worked or not.
Dim myLastRow As Long
Dim myResult As Long
Dim myTableRange As Range
myLastRow = Cells(Rows.Count, 1).End(xlUp).Row
If ComboBox1.Value = "Serial" Then
Set myTableRange = Range("B1:B" & myLastRow)
myResult = Application.Match(TextBox1.Value, myTableRange, 0) 'Returns row number only
ElseIf ComboBox1.Value = "MII" Then
Set myTableRange = Range("A1:A" & myLastRow)
myResult = Application.Match(TextBox1.Value, myTableRange, 0) 'Returns row number only
Else
MsgBox ("No Range Selected")
End If
Dim objWord, objDoc As Object
Set objWord = GetObject(, "Word.Application")
objWord.Visible = True
Dim tableRow As Long
Dim rowCount As Long
Dim lastTableCell As Long
Dim i As Long
Dim cellEmpty As Boolean
'lastTableCell = 28 'Defualt input range is from cell 13 to 28
lastTableCell = 100
cellEmpty = True
findEmptyCell:
For i = 13 To lastTableCell
If objWord.ActiveDocument.Tables(1).Cell(i, Column:=1).Range.Text = Chr(13) & Chr(7) Then
tableRow = i
cellEmpty = True
GoTo rowFound
End If
allCellsFilled:
If cellEmpty = False Then
objWord.ActiveDocument.Tables.Item(1).Rows(i - 1).Select
Selection.InsertRowsBelow (i - 1)
cellEmpty = True
GoTo findEmptyCell
End If
Next i
rowFound:
On Error GoTo errorHappened
objWord.ActiveDocument.Tables(1).Cell(Row:=tableRow, Column:=1).Range.Text = "1"
objWord.ActiveDocument.Tables(1).Cell(Row:=tableRow, Column:=2).Range.Text = Cells(myResult, 1).Value
objWord.ActiveDocument.Tables(1).Cell(Row:=tableRow, Column:=3).Range.Text = Cells(myResult, 2).Value
objWord.ActiveDocument.Tables(1).Cell(Row:=tableRow, Column:=4).Range.Text = Cells(myResult, 3).Value & ", " & Cells(myResult, 4).Value & ", Model # " & Cells(myResult, 5).Value
GoTo endTheSub
errorHappened:
cellEmpty = False
GoTo allCellsFilled
endTheSub:
End Sub
I have a excel workbook which has 30 worksheets in it. Each sheet looks something like this
Now i want to insert a column after "I" column (the new column will be J)and the values should be some thing like this
for coupon 2.000(4-7 rows) the values in the new column J should be = i4-i5(For all J4,5,6,7)
This should be repeated for each coupon.
I tried recording the macro but did not help.
Please provide me sample logic to handle this dynamically.
Thank you in advance.
From your description, it sounded like this is what you are looking for. Please let me know if that is not the case.
Sub AddNewColumn()
Dim sColumnToIns, sCouponField, sCouponGroup, _
sFormula, sCell1, sCell2, sMarketValueField, sColumnToInsHeader, sTopCellOfData
Dim rData As Range
Dim rRng As Range
Dim rCell As Range
Dim oSh As Worksheet
'Make sure you change the sheet to reflect
'the object name of your sheet.
Set oSh = Sheet2
sColumnToIns = "J"
sColumnToInsHeader = "New Column"
sCouponField = "B"
sMarketValueField = "I"
sTopCellOfData = "A4"
'Insert a new column
Sheet1.Range(sColumnToIns & ":" & sColumnToIns).Insert xlShiftToRight
'Get lowest cell in used range
Set rRng = oSh.UsedRange.Cells(oSh.UsedRange.Rows.Count, oSh.UsedRange.Columns.Count)
Set rData = oSh.Range(sTopCellOfData, rRng)
'Set the header text
rData.Range(sColumnToIns & "1").Offset(-1).Value = sColumnToInsHeader
'Go through the entire data set. Whenever the value in the 'Coupon'
'column changes, put a formula the subtracts the top market value
'from the next market value down.
sCouponGroup = ""
For Each rCell In rData.Columns(sCouponField).Cells
If sCouponGroup <> rCell.Value Then
sCouponGroup = rCell.Value
sCell1 = rCell.EntireRow.Columns(sMarketValueField).Address
sCell2 = rCell.EntireRow.Columns(sMarketValueField).Offset(1).Address
sFormula = "=" & sCell1 & "-" & sCell2
End If
rCell.EntireRow.Columns(sColumnToIns).Formula = sFormula
Next
End Sub
I have the following Public sub:
Public Sub HowToSort()
Dim i As Long, j As Long, h As Long, curCell As Range, cellBelow(1 To 10) As Variant
Dim sortOrder(1 To 10), colIsString(1 To 10) As Variant
For i = 1 To hdrCount
'Find location of a cell
Set curCell = Application.WorksheetFunction.Match(headRow(i), Range("a1:z1")) ' Eventually extend outwards?
cellBelow(i) = curCell.Offset(0, 1).Value
If IsNumeric(cellBelow(i)) = False Then
colIsString(i) = True
sortOrder(i) = Application.InputBox(prompt:="Alphabetical = 'True' or Reverse Alphabetical = 'False' sorting for " & headRow(i), Type:=4)
ElseIf IsNumeric(cellBelow(i)) = True Then
colIsString(i) = False
sortOrder(i) = Application.InputBox(prompt:="Ascending = True or Descending = False for " & headRow(i), Type:=4)
Else
MsgBox ("Program does not recognize value contained in column" & headRow(i))
End
End If
Next i
End Sub
Which uses a global variable named headRow, containing an array of strings of names of the header row at the top of the worksheet. I am trying to use the match function to find the address of the cell where the header is located:
Set curCell = Application.WorksheetFunction.Match(headRow(i), Range("a1:z1"))
cellBelow(i) = curCell.Offset(0, 1).Value
I then want to use this address, offset it downwards one cell to find what type of data is entered, this data will be entered in array colIsString. However, the .Match function is not working, citing a 'Type Mismatch' error. I do not know how this could be? From my previous research it appears that the .Match command takes in a range, then searches that range to match a cell value. I have tried several incarnations of the .Match command with no success. Your thoughts appreciated...
H3lue
Use Find() instead:
Set curCell = Range("a1:z1").Find(headRow(i), , xlValues, xlWhole)
If Not curCell Is Nothing Then
'found the header
cellBelow(i) = curCell.Offset(0, 1).Value
'etc etc
Else
MsgBox "Header '" & headRow(i) & "' not found!"
End If
sortOrder and colIsString will go out of scope as soon as your sub exits though...