I am looking to list all table names in a sheet, together with the table's corresponding cell in the last row and column. The below code finds the table names in sheet "A1.6Laster" (Except table "Lastkategori") and then lists them in sheet "A1.6.5Lastkombinationer".
Since I can add/delete tables i sheet "A1.6Laster", the list is first deleted/cleared.
In other words; the below code work fine listing the names of the tables, but in the column next to the name list I want each table's corresponding cell in the last row and column to be listed as well. Do I need to add some code in the For Each loop?
Any input is welcome, and please ask if you need further information!
Sub Laster()
Dim tbl As ListObject
Dim wsSummary As Worksheet
Dim ws As Worksheet
Dim lRow As Long
Dim SearchText As String
Dim GCell As Range
SearchText = "Laster"
Set GCell = Worksheets("A1.6.5Lastkombinationer").Cells.Find(SearchText).Offset(0)
Set wsSummary = Worksheets("A1.6.5Lastkombinationer")
Set ws = Worksheets("A1.6Laster")
With Worksheets("A1.6.5Lastkombinationer").ListObjects("Laster").DataBodyRange
If .Rows.Count > 1 Then
.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
End If
End With
Worksheets("A1.6.5Lastkombinationer").ListObjects("Laster").DataBodyRange.Rows(1).ClearContents
lRow = GCell.Row
For Each tbl In Worksheets("A1.6Laster").ListObjects
If tbl.Name <> "Lastkategori" Then
lRow = lRow + 1
With wsSummary
.Cells(lRow, "A") = tbl.Name
End With
End If
Next tbl
ws.ListObjects("Lastkategori").ListColumns(1).DataBodyRange.Copy
wsSummary.ListObjects("Laster").DataBodyRange(1, 1).End(xlDown).Offset(1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
I am assuming when you say last row and column means the bottom right hand corner cell of each table.
Add the following snippet within With wsWsummary ... End With. What it does is it takes the range of cells for each table's data range and gets the last row's last column and spits out the data in that cell into the column next to the table's name.
Dim r As Range
Dim last As Range
Set r = tbl.DataBodyRange
Set last = r.Cells(r.Rows.Count, r.Columns.Count)
ws.Cells(lRow, "B").Value = last
Related
I created a VBA Script which compares a sheet named "New Data" and a sheet named "Old Data" to return only rows with a column differing. I created this in order to find back dating which occurs from time to time, so the two sheets "New Data" and "Old Data" should be identical with 1-5 differences, sometimes they add a new row, sometimes they take one of the old data and change the value attached to it. This is why I have it checking as unique rows, its fine if column a-y is identical but once column z differs then its a unique row.
Please see code below:
Sub CompareSheets()
'Declare variables for the two sheets
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
'Set the variables to the appropriate sheets
Set sheet1 = ThisWorkbook.Sheets("New Data")
Set sheet2 = ThisWorkbook.Sheets("Old Data")
'Declare a variable for the last row in each sheet
Dim lastRow1 As Long
Dim lastRow2 As Long
'Set the last row variables to the last used row in each sheet
lastRow1 = sheet1.Cells(sheet1.Rows.Count, "A").End(xlUp).Row
lastRow2 = sheet2.Cells(sheet2.Rows.Count, "A").End(xlUp).Row
'Declare a variable for the first empty row in a new sheet
Dim nextRow As Long
'Create a new sheet to hold the unique rows
ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = "Unique Rows"
'Set the first empty row variable to the first row of the new sheet
nextRow = 1
' Create a dictionary object
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
' Add the data from sheet2 to the dictionary
Dim key As String
For row2 = 2 To lastRow2
key = ""
For col = 1 To sheet2.Cells(1, sheet2.Columns.Count).End(xlToLeft).Column
key = key & sheet2.Cells(row2, col)
Next col
dict.Add key, row2
Next row2
' Turn off screen updating and calculation during execution
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Loop through each row in sheet1
For row1 = 2 To lastRow1
key = ""
'Create a key for the current row
For col = 1 To sheet1.Cells(1, sheet1.Columns.Count).End(xlToLeft).Column
key = key & sheet1.Cells(row1, col)
Next col
'Check if the key exists in the dictionary
If Not dict.Exists(key) Then
For col = 1 To sheet1.Cells(1, sheet1.Columns.Count).End(xlToLeft).Column
ThisWorkbook.Sheets("Unique Rows").Cells(nextRow, col).Value = sheet1.Cells(row1, col).Value
Next col
nextRow = nextRow + 1
End If
Next row1
'Turn on screen updating and calculation
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I've had this script work and give me unique variables from time to time but in some cases it gives me an error: Run-Time Error '457': That key is already associated with an element of this collection. I've received one other error Run-Time Error '1004' but that's only when Unique Rows sheet already exists, if I delete it would fix this issue. Can you please assist on having this code run smoothly without error?
Thank you, I appreciate your time and effort!
I have a excel which has multiple rows and columns and range of column values differ for each row.
Need a macro which will delete all cells in a row except first and last in each row and paste the last value next to first value.
Tried the below script:
Sub test()
Dim sh As Worksheet
Dim IDS As range
Dim ID As range
Set sh = ThisWorkbook.Sheets("Sheet1")
Set IDS = ActiveSheet.range("A2", range("A1").End(xlDown))
For Each ID In IDS
Dim b As Integer
Dim k As Integer
k = sh.range("ID", sh.range("ID").End(xlToRight)).Columns.Count
b = k - 1
range(ID.Offset(0, 0), ID.Offset(0, "b")).Select
Selection.ClearContents
Next ID
End Sub
This is a little different approach but should help.
Also, it is generally not best to declare variables in a loop as you do with b & k just fyi
Sub test()
Dim sh As Worksheet
Dim row As Integer
Dim lastCol As Integer
Set sh = ThisWorkbook.Sheets("Sheet1")
For row = 2 To sh.Cells(Sheets(1).Rows.Count, "A").End(xlUp).row
lastCol = sh.Cells(row, Columns.Count).End(xlToLeft).Column
sh.Range("B" & row).Value = sh.Cells(row, lastCol).Value
sh.Range(sh.Cells(row, 3), sh.Cells(row, lastCol)).ClearContents
Next
End Sub
Best of luck
I'd go as follows:
Sub test()
Dim cell As Range
With ThisWorkbook.Sheets("Sheet1") ' reference relevant sheet
For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) ' loop through referenced sheet column A cells from row 2 down to last not empty one
With .Range(cell, .Cells(cell.Row, .Columns.Count).End(xlToLeft)) ' reference referenced sheet range spanning from current cell to last not empty one in the same row
If .Count > 2 Then ' if referenced range has more then 2 cells
cell.Offset(, 1).Value = .Cells(1, .Count).Value ' store last cell value next to the current one
.Offset(, 2).Resize(, .Columns.Count - 1).ClearContents 'clear all cells right of current one
End If
End With
Next
End With
End Sub
You can use Range.Delete Method (Excel)
range(ID.Offset(0, 0), ID.Offset(0, b)).Delete Shift:=xlToLeft
The main goal is: Retrieve specific cell values from each row in a filtered table by using column reference name.
So far, I have the following code
Dim table As listObject
Dim columns As ListColumns
Dim row As ListRow
Dim rnData As range
Dim rngArea As range
Set table = Sheets(sheetName).ListObjects(TableName)
Set columns = table.ListColumns
Set rnData = ThisWorkbook.Worksheets(sheetName).ListObjects(TableName).range
'Notice that sheetName and TableName are function arguments. No need to pay attention. Consider any string values.
'Filter my table
table.range.AutoFilter Field:=7, Criteria1:=Array("filtervalue1", "filtervalue2"), Operator:=xlFilterValues
'Set the filtered table in a new Range object
Set rnData = ThisWorkbook.Worksheets(sheetName).ListObjects(TableName).range
'Count all rows of my filtered table
With rnData
For Each rngArea In .SpecialCells(xlCellTypeVisible).Areas
lCount = lCount + rngArea.Rows.Count
Next
End with
Now I want to loop my filtered table (my "rnData" range) and I want to get the cell value for each row in those Range.Areas.
I was thinking something like this, but i'm having difficulties with VBA to do this:
For iRowNo = 2 To (lCount - 1) 'Start at 2 because 1 is the table header
'This does not work once it gets another row from the entire table. Not the filtered one. Help here!
Set row = table.ListRows(iRowNo)
'Something close to this - Help Here!
Set row = rnData.SpecialCells(xlCellTypeVisible).Areas
''Would like to have the code like this to get the values
cell1Value= row.range(1, columns("My Column Header 1").Index).value
cell2Value= row.range(1, columns("My Column Header 2").Index).Value
Next iRowNo
Let me know if there are different solutions than this.
Following the #DirkReichel answer
Here is the code that worked for me:
Dim table As listObject
Dim columns As ListColumns
Dim row As ListRow
Dim rnData As range
Dim rngArea As range
Set table = Sheets(sheetName).ListObjects(TableName)
Set columns = table.ListColumns
Set rnData = ThisWorkbook.Worksheets(sheetName).ListObjects(TableName).range
'Notice that sheetName and TableName are function arguments. No need to pay attention. Consider any string values.
'Filter my table
table.range.AutoFilter Field:=7, Criteria1:=Array("filtervalue1", "filtervalue2"), Operator:=xlFilterValues
'Set the filtered table in a new Range object
Set rnData = ThisWorkbook.Worksheets(sheetName).ListObjects(TableName).range
'Get values for each row
With rnData
For Each rngArea In .SpecialCells(xlCellTypeVisible).Areas
For Each row In rngArea.Rows
cell1Value= row.range(1, columns("My Column Header 1").Index).value
cell2Value= row.range(1, columns("My Column Header 2").Index).Value
Next
'lCount = lCount + rngArea.Rows.Count 'Removed this.
Next
End with
'Also no need the second part of code with the For..Next loop.
I think you're indirectly trying to create an array which is not something that can be easily explained a single post, but here's some code to get you started.
I'm going to assume that your set rnData range is correct. From there, it's probably easiest to just loop through all cells in range. You could write code more precise than below, but this should help you see a couple ideas besides what you're trying.
Most important I think you're looking for a method to create an array. I hope this helps.
Sub testCoutinho()
Dim Rcell As Range
Dim rnData As Range 'you'll have to set this up...
Dim YesLetsDoAnArray As Boolean: YesLetsDoAnArray = False 'or change to false to just make a new sheet with values
If YesLetsDoAnArray Then
ReDim This_is_your_Array(0) As Variant 'Create Array
Dim x As Integer
Else
'putting values on a new worksheet in file
Dim CleanWS As Worksheet: Set CleanWS = ThisWorkbook.Sheets.Add
End If
For Each Rcell In rnData.Cells
If Rcell.EntireRow.Hidden = False Then
If YesLetsDoAnArray Then
ReDim Preserve This_is_your_Array(x)
This_is_your_Array(x) = Rcell.Value
x = x + 1
Else
CleanWS.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Rcell.Value
End If
End If
Next Rcell
'If you used an array, you'll know have variable(s) that contain all your data.
'your first one is This This_Is_Your_Array(0), followed by This_Is_Your_Array(1)... etc.
'you can play around. this will print them all.
If YesLetsDoAnArray Then
Dim i As Integer
For i = 0 To x - 1
Debug.Print This_is_your_Array(i)
Next i
End If
End Sub
Sub Search2 ()
Dim endRowsl As Long
endRowsl = Sheets ("Orders").Cells.Rows.Count, "A").End(xlUp).Row
Dim countRows4 As Integer
countRows4 = 4
Dim x1Range As Range
Dim xlCell As Range
Dim xlSheet As Worksheet
Dim keyword As String
Set xlSheet = Worksheets ("Tag50")
Set x1Range = xlSheet.Range ("Al :A5")
For j = 2 To endRowsl
keyword = Sheets("Order").Range("B" & j ).Value
For Each xlCell In x1Range
If xlCell.Value = keyword Then
Next xlCell
ElseIf Not xlCell.Value = keyword Then
Sheets ("Test").Rows(countRows4).Value = Sheets("Order").Rows(j).Value
countRows4 = countRows4 + 1
Next xlCell
End If
Next
End Sub
What I have right now that is not giving me anything. I believe my logic is correct, but my syntax is not?
First time at VBA. I am trying to loop through the first sheet 'orders' to find each value in column B in the second sheet. If the value is NOT there, I need to match the column A value in sheet 1 to the same value in sheet 3, then return the value in column B of sheet 3. I understand the logic behind it, but I am not sure how to write the VBA code. I have posted what I have here.
Any help on syntax, logic, format, etc., is appreciated
Your almost there! What you need is a Scripting.Dictionary.
Dictionary store data in {Key, Value} pairs. Reference a Dictionary's Key and it'll return it's value. Reference it's value and it'll give you it's key. Because Keys are unique you should test if they exist before you try and add them.
Here is the Psuedo Code for what you are trying to accomplish.
Sub Search2()
Dim keyword As String, keyvalue As Variant
Dim dicOrders
Set dicOrders = CreateObject("scripting.dictionary")
With Worksheets("orders")
Begin Loop
keyword = .Cells(x, 1)
keyvalue = .Cells(x, 1)
'Add Key Value pairs to Dictionary
If Not dicOrders.Exists(keyword) Then dicOrders.Add keyword, keyvalue
End Loop
End With
With Worksheets("tag50")
Begin Loop
keyword = .Cells(x, 1)
'If keyword exist remove Key from Dictionary
If dicOrders.Exists(keyword) Then dicOrders.Remove keyword
End Loop
End With
' Now dicOrders only has unmatched orders in it
With Worksheets("Test")
Begin Loop
keyword = .Cells(x, 1)
'If keyword exist write keyvalue to Column B
If dicOrders.Exists(keyword) Then .Cells(x, 2) = dicOrders(keyword)
End Loop
End With
End Sub
I prefer to use For Loops over For Each loop to iterate over rows.
This is my code pattern. It's very easy to expand.
With Worksheets("Test")
For x = 2 To lastRow
Data1 = .Cells(x, 1)
Data2 = .Cells(x, 2)
Data3 = .Cells(x, 3)
Data5 = .Cells(x, 5)
Next
End With
here's a possible solution
Option Explicit
Sub main()
Dim orderRng As Range, tag50Rng As Range, sheet3Rng As Range, testRng As Range
Dim cell As Range, found As Range
Dim testRowsOffset As Long
Set orderRng = GetRange("orders", "B", 2) '<--| set sheet "order" column "B" cells from row 2 down to last non empty one as range to seek values of in other ranges
Set tag50Rng = GetRange("tag50", "A") '<--| set sheet "tag50" column "A" cells from row 1 down to last non empty one as range where to do 1st lookup in
Set sheet3Rng = GetRange("sheet3", "A") '<--| set sheet "sheet3" column "A" cells from row 1 down to last non empty one as range where to do 2nd lookup in
Set testRng = Worksheets("test").Range("A4") '<--| set sheet "test" cell "A4" as range where to start returning values from downwards
For Each cell In orderRng '<--| loop through each cell of "order" sheet column "B"
Set found = tag50Rng.Find(what:=cell.Value, lookat:=xlWhole, LookIn:=xlValues) '<--| lookup for current cell value in "tag50" column "A"
If found Is Nothing Then '<--| if no match found
Set found = sheet3Rng.Find(what:=cell.Offset(, -1).Value, lookat:=xlWhole, LookIn:=xlValues) '<--| lookup for current cell offsetted 1 column left value in "sheet3" column "A"
If Not found Is Nothing Then '<--| if match found
testRng.Offset(testRowsOffset) = found.Offset(, 1).Value '<--| return sheet3 found cell offsetted 1 column right value
testRowsOffset = testRowsOffset + 1 '<--| update row offset counter from "test" cell A4
End If
End If
Next cell
End Sub
Function GetRange(shtName As String, col As String, Optional firstRow As Variant) As Range
' returns the range of the passed worksheet in the passed column from passed row to last non empty one
' if no row is passed, it starts from row 1
If IsMissing(firstRow) Then firstRow = 1
With Worksheets(shtName)
Set GetRange = .Range(.Cells(1, col), .Cells(.Rows.Count, col).End(xlUp))
End With
End Function
change all relevant parameters (sheet names, their columns to lookup in and rows to start from) as per your needs
This is my first time to code in VBA.
I have several worksheets in a file and they are in order by dates.
So what I am trying to do is to collect data sets in a worksheet if they have the same period of time.
date1 value1
date2 value2
date3 value3
Since they are in order I just compare the first date values and if they are different it moves on to the next worksheet. If they are the same then copy the value and do the same process until it reaches the last worksheet.
However it copies one worksheet fine but after that Excel freezes.
I would be appreciated if you find any errors or give me other suggestions to do it.
Following is my code:
Sub matchingStock()
Dim sh1 As Worksheet, sh2 As Worksheet
' create short references to sheets
' inside the Sheets() use either the tab number or name
Set sh1 = Sheets("combined")
Dim col As Long
'since first column is for Tbill it stock price should place from the third column
col = 3
Dim k As Long
'go through all the stock worksheets
For k = Sheets("WLT").Index To Sheets("ARNA").Index
Set sh2 = Sheets(k)
' Create iterators
Dim i As Long, j As Long
' Create last rows values for the columns you will be comparing
Dim lr1 As Long, lr2 As Long
' create a reference variable to the next available row
Dim nxtRow As Long
' Create ranges to easily reference data
Dim rng1 As Range, rng2 As Range
' Assign values to variables
lr1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
Application.ScreenUpdating = False
' Loop through column A on sheet1
For i = 2 To lr1
Set rng1 = sh1.Range("A" & i)
' Loop through column A on sheet1
For j = 2 To lr2
Set rng2 = sh2.Range("A" & j)
' compare the words in column a on sheet1 with the words in column on sheet2
'Dim date1 As Date
'Dim date2 As Date
'date1 = TimeValue(sh1.Range("A3"))
'date2 = TimeValue(sh2.Range("A3"))
sh1.Cells(1, col).Value = sh2.Range("A1").Value
' find next empty row
nxtRow = sh1.Cells(Rows.Count, col).End(xlUp).Row + 1
' copy the word in column A on sheet2 to the next available row in sheet1
' copy the value ( offset(0,1) Column B ) to the next available row in sheet1
sh1.Cells(nxtRow, col).Value = rng2.Offset(0, 6).Value
'when the date is different skip to the next worksheet
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i
'sh3.Rows("1:1").Delete
Else
GoTo Skip
End If
Skip:
col = col + 1
Next k
End Sub
I cannot identify a specific error so this is a list of suggestions that may help you identify the error and may help improve your code.
Suggestion 1
Do you think the Else block of If-Then-Else-End-If is compulsory?
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
:
Else
GoTo Skip
End If
Skip:
is the same as:
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
:
End If
Suggestion 2
I do not like:
For k = Sheets("WLT").Index To Sheets("ARNA").Index
The value of property Index for a worksheet may not what you think it is. This may not give you the set or sequence of worksheets you expect. Do you want every worksheet except "Combined"? The following should be more reliable:
For k = 1 To Worksheets.Count
If Worksheets(k).Name <> sh1.Name Then
:
End If
Next
Suggestion 3
You use:
.Range("A" & Rows.Count)
.Range("A3")
.Cells(1, col).Value
.Cells(Rows.Count, col)
rng2.Offset(0, 6)
All these methods of identifying a cell or a range have their purposes. However, I find it confusing to use more than one at a time. I find .Cells(row, column) and .Range(.Cells(row1, column1), .Cells(row2, column2)) to be the most versatile and use them unless there is a powerful reason to use one of the other methods.
Suggestion 4
I cannot decypher what this code is attempting to achieve.
You say: "I have several worksheets in a file and they are in order by dates. So what I am trying to do is to collect data sets in a worksheet if they have the same period of time."
If you have set Worksheet("combined").Range("A3").Value to a particular date and you want to collect data from all those sheets with the same value in cell A3 then the outer For-Loop and the If give this effect. But if so, if does not matter how the worksheets are ordered. Also you start checking cell values from row 2 which suggests row 3 is a regular data row.
The outer loop is for each worksheet, the next loop is for each row in "combined" and the inner loop is for each row in the worksheet selected by the outer loop. The middle loop does not appear to do anything but set rng1 which is not used.
Perhaps you can add an explanation of what you are trying to achieve.
Suggestion 5
Are you trying to add an entire column of values from the source worksheets to "Combined". The macro below:
Identifies the next free row in column A of "Combined"
Identifies the last used row in column A of "Sheet2"
Assumes the first interesting row of "Sheet2" is 2.
Adds the entire used range of column A of "Sheet2" (complete with formatting) to the end of "Combined"'s column A in a single statement.
This may demonstrate a better way of achieving the effect you seek.
Sub Test()
Dim RngSrc As Range
Dim RngDest As Range
Dim RowCombNext As Long
Dim RowSrcFirst As Long
Dim RowSrcLast As Long
With Worksheets("Combined")
RowCombNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Set RngDest = .Cells(RowCombNext, "A")
End With
With Worksheets("Sheet2")
RowSrcFirst = 2
RowSrcLast = .Cells(Rows.Count, "A").End(xlUp).Row
Set RngSrc = .Range(.Cells(RowSrcFirst, "A"), .Cells(RowSrcLast, "A"))
End With
RngSrc.Copy Destination:=RngDest
End Sub