I have a list of part numbers as shown below, each one has a range start and end value which needs to replace the *** in the part number.
I am trying to identify the range start and end value, look them up on the range list on sheet2 (RangeTable) and then concatenate that with the part number individually, so for each part number in column A, a range value defined in column B and C will be concatenated on sheet3 (PartNumbers).
The code is not identifying the Range Start and End value and is creating a part number for all values on the Range Table.
Sub CompilePartNums()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet
Dim LR1 As Long
Dim LR2 As Long
Dim LR3 As Long
Dim Ctr1 As Long
Dim Ctr2 As Long
Set WS1 = Worksheets("Tabelle1")
Set WS2 = Worksheets("RangeTable")
Set WS3 = Worksheets("PartNumbers")
With WS1
LR1 = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With WS2
LR2 = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
LR3 = 2
For Ctr1 = 2 To LR1
For Ctr2 = 2 To LR2
Select Case WS2.Cells(Ctr2, 1)
Case WS1.Cells(Ctr1, 2) To WS1.Cells(Ctr1, 3)
WS3.Cells(LR3, 1) = replace(WS1.Cells(Ctr1, 1), "***", WS2.Cells(Ctr2, 1))
LR3 = LR3 + 1
End Select
Next
Next
End Sub
Sheet1 (Tabelle1) Looks like this and continues down to ROW1210
Sheet2 (RangeTable) looks like this, the values in this need to stay in this order which are not sequential
Sheet3 (PartNumbers) is the results that are output, it should stop at 390 however it continues thru all the RangeTable values.
I'll post this as an "answer" for the moment, simply because it is too complicated to explain in a comment, but I think it might have something to do with your issue.
You have a Select Case statement of:
Select Case WS2.Cells(Ctr2, 1)
Case WS1.Cells(Ctr1, 2) To WS1.Cells(Ctr1, 3)
WS3.Cells(LR3, 1) = replace(WS1.Cells(Ctr1, 1), "***", WS2.Cells(Ctr2, 1))
LR3 = LR3 + 1
End Select
That statement is effectively equivalent to
If WS2.Cells(Ctr2, 1) >= WS1.Cells(Ctr1, 2) And _
WS2.Cells(Ctr2, 1) <= WS1.Cells(Ctr1, 3) Then
WS3.Cells(LR3, 1) = replace(WS1.Cells(Ctr1, 1), "***", WS2.Cells(Ctr2, 1))
LR3 = LR3 + 1
End If
And that statement is basically saying that if a record in column A of the RangeTable sheet is greater than or equal to the value in column B of the Tabelle1 sheet and less than or equal to the value in column C of the Tabelle1 sheet, then create a new cell in column A of the PartNumbers sheet with a value of column A of the Tabelle1 sheet (with any "***" in that value replaced by the value in column A of the RangeTable sheet).
Considering that none of your sheets have anything in column B or C, I can't understand how your code managed to write anything to the PartNumbers sheet ?!?!
Related
Hope you you can help me here. I have a repetitive task every week, which I could do the same way every single time through Excel formulas, but I am looking for a more automated way of going about this.
What I want to achieve is to set-up a dynamic range that will look for multiple key words such as in this case "OA" & "SNC" and if it matches it will return the value in the column G & H respectively. At the same time it has to skip blank rows. What is the best way to go about this?
I figured it shouldn't be too hard, but I cannot figure it out.
As per image above, I want to consolidate the charges per category (OA & SNC) in the designated columns ("G" & "H") on row level.
My approach to the task
Procedure finds data range, loops through it's values, adding unique values to the dictionary with sum for specific row and then loads all these values along with sums per row.
Option Explicit
Sub CountStuff()
Dim wb As Workbook, ws As Worksheet
Dim lColumn As Long, lRow As Long, lColTotal As Long
Dim i As Long, j As Long
Dim rngData As Range, iCell As Range
Dim dictVal As Object
Dim vArr(), vArrSub(), vArrEmpt()
'Your workbook
Set wb = ThisWorkbook
'Set wb = Workbooks("Workbook1")
'Your worksheet
Set ws = ActiveSheet
'Set ws = wb.Worksheets("Sheet1")
'Number of the first data range column
lColumn = ws.Rows(1).Find("1", , xlValues, xlWhole).Column
'Number of the last row of data range
lRow = ws.Cells(ws.Rows.Count, lColumn).End(xlUp).Row
'Total number of data range columns
lColTotal = ws.Cells(1, lColumn).End(xlToRight).Column - lColumn + 1
'Data range itself
Set rngData = ws.Cells(1, lColumn).Resize(lRow, lColTotal)
'Creating a dictionary
Set dictVal = CreateObject("Scripting.Dictionary")
'Data values -> array
vArr = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1, _
rngData.Columns.Count).Value
'Empty array
ReDim vArrEmpt(1 To UBound(vArr, 1))
'Loop through all values
For i = LBound(vArr, 1) To UBound(vArr, 1)
For j = LBound(vArr, 2) To UBound(vArr, 2)
'Value is not numeric and is not in dictionary
If Not IsNumeric(vArr(i, j)) And _
Not dictVal.Exists(vArr(i, j)) Then
'Add value to dictionary
dictVal.Add vArr(i, j), vArrEmpt
vArrSub = dictVal(vArr(i, j))
vArrSub(i) = vArr(i, j - 1)
dictVal(vArr(i, j)) = vArrSub
'Value is not numeric but already exists
ElseIf dictVal.Exists(vArr(i, j)) Then
vArrSub = dictVal(vArr(i, j))
vArrSub(i) = vArrSub(i) + vArr(i, j - 1)
dictVal(vArr(i, j)) = vArrSub
End If
Next j
Next i
'Define new range for results
Set rngData = ws.Cells(1, lColumn + lColTotal - 1). _
Offset(0, 2).Resize(1, dictVal.Count)
'Load results
rngData.Value = dictVal.Keys
For Each iCell In rngData.Cells
iCell.Offset(1, 0).Resize(lRow - 1).Value _
= Application.Transpose(dictVal(iCell.Value))
Next
End Sub
I've used a simple custom function, possibly overkill as this could be done with worksheet formulae, but given that your ranges can vary in either direction...
Function altsum(r As Range, v As Variant) As Variant
Dim c As Long
For c = 2 To r.Columns.Count Step 2
If r.Cells(c) = v Then altsum = altsum + r.Cells(c - 1)
Next c
If altsum = 0 Then altsum = vbNullString
End Function
Example below, copy and formula in F2 across and down (or apply it one go with another bit of code).
what I'm trying to do is look at 2 different sheets to compare people and their National insurance Number.
Sheet 1 is one set of data from one system and Sheet 2 is another set of data from a different system. What I want to do is firstly compare column 1 in both sheets which contains an id unique to that person , once the entry in column1 on in each sheet are the same and this is then the same person. Then
What I then want to do is compare the value that's stored 17 columns to the right of column 1 on Sheet 1 and 23 Columns to the right on Sheet 2 (Both are national insurance numbers).
Only if they are different then I want to copy the first 3 columns of the row from Sheet 1 (Number, FirstName and Surname) and the national insurance number value from both sheets (Sheet1(0,17)Sheet2(0,23) to Sheet3.
This is code I am trying that instiallially copies entire row which if the logic worked I could change to copy only the cells I want but to no avail it seems to be copying almost the entire sheet 1.....
Sub compareData()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Long, j As Long
Dim newSheetPos As Integer
Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set ws2 = ActiveWorkbook.Sheets("Sheet2")
Set ws3 = ActiveWorkbook.Sheets("Sheet3")
newSheetPos = ws3.Cells(ws3.Rows.Count, 2).End(xlUp).Row
For i = 1 To ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Row
For j = 1 To ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row
If ws1.Cells(i, 1).Value = ws2.Cells(j, 1).Value Then
If ws1.Cells(i, 17).Value <> ws2.Cells(j, 23).Value Then
ws1.Cells(j, 1).EntireRow.Copy ws3.Cells(newSheetPos, 1)
newSheetPos = newSheetPos + 1
Else
End If
Else
End If
Next j
Next i
End Sub
Having run into similar problems, I have found that using Trim(), UCase() and the .Value2 property eliminate many of mismatches caused by formatting and/or text case. Your code should look something like this if you use Trim() and .Value2.
If Trim(ws1.Cells(i, 1).Value2) = Trim(ws2.Cells(j, 1).Value2) Then
If Trim(ws1.Cells(i, 17).Value2) <> Trim(ws2.Cells(j, 23).Value2) Then
ws1.Cells(j, 1).EntireRow.Copy ws3.Cells(newSheetPos, 1)
newSheetPos = newSheetPos + 1
Else
End If
End If
The value stored in a cell can be referenced by .Text, .Value or .Value2. Value2 provides the underlying value without any formating. TEXT vs VALUE vs VALUE2 is a link to an article providing an excellent explanation.
Hello I have sorted this now, I realised that as the offset starts from 1 and not 0 that I had to increment the criteria offset by 1 please see below
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Long, j As Long
Dim newSheetPos As Integer
Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set ws2 = ActiveWorkbook.Sheets("Sheet2")
Set ws3 = ActiveWorkbook.Sheets("NINO Differences")
newSheetPos = ws3.Cells(ws3.Rows.Count, 2).End(xlUp).Row
For i = 1 To ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Row
For j = 1 To ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row
If Trim(ws1.Cells(i, 1).Value2) = Trim(ws2.Cells(j, 1).Value2) Then
If Trim(ws1.Cells(i, 17).Value2) <> Trim(ws2.Cells(j, 24).Value2) Then
ws1.Cells(j, 1).EntireRow.Copy ws3.Cells(newSheetPos, 1)
newSheetPos = newSheetPos + 1
Else
End If
Else
End If
Next j
Next i
I am currently working on a macro and I had it working 100% like I wanted, but when I went to move the control group to a different sheet, I've started getting all sorts of problems. Here is the code:
Sub Duplicate_Count()
'Diclare Variables
Dim LastRow As Long
Dim value1 As String
Dim value2 As String
Dim counter As Long
Dim startRange As Long
Dim endRange As Long
Dim inColumn As String
Dim outColumn As String
Dim color As Long
counter = 0
Dim sht As Worksheet
Dim controlSht As Worksheet
Set sht = Worksheets("Sheet1")
Set controlSht = Worksheets("Duplicate Check")
'Find the last used row in column L
LastRow = sht.Cells(Rows.Count, "L").End(xlUp).Row
'set default ranges
startRange = 2
endRange = LastRow - 1
inColumn = "L"
outColumn = "N"
'check for user inputs
If controlSht.Cells(8, "B") <> "" Then
startRange = controlSht.Cells(8, "B")
End If
If controlSht.Cells(8, "C") <> "" Then
endRange = controlSht.Cells(8, "C")
End If
If controlSht.Cells(11, "C") <> "" Then
Column = controlSht.Cells(11, "C")
End If
If controlSht.Cells(14, "C") <> "" Then
Column = controlSht.Cells(14, "C")
End If
color = controlSht.Cells(17, "C").Interior.color
'Search down row for duplicates
Dim i As Long
For i = startRange To endRange
'Sets value1 and value2 to be compared
value1 = sht.Cells(i, inColumn).Value
value2 = sht.Cells(i + 1, inColumn).Value
'If values are not diferent then counter will not increment
counter = 1
Do While value1 = value2
sht.Cells(i, inColumn).Interior.color = color
sht.Cells(i + counter, inColumn).Interior.color = color
counter = counter + 1
value2 = sht.Cells(i + counter, inColumn).Value
Loop
'Ouput the number of duplicates on last duplicates row
If counter <> 1 Then
sht.Cells(i + counter - 1, outColumn) = counter
i = i + counter - 1
End If
Next i
End Sub
This is my first program so I apologize for all the mistakes. This code does exactly what I want except for finding the last row if there is no user input. It always says the last row is 1, when it should be 110460. I'm not sure if it's grabbing from the wrong sheet or if there is an error in my logic.
This should be easy to fix by just Activating the sheet first. I can't recall the exact syntax but since you tagged this macros just record a macro, then select a sheet and click on it somewhere. Then open up the macro it will say something like Sheets("sheet name".Activate. Or Sheets("sheet name").Select. Repeat that for each worksheet you want to run the macro on. To clarify, each time your macro finds the last row on 1 sheet, then you Activate or Select the next worksheet and find the last row again. Suppose this is being called in a loop through list of worksheet names.
I changed the "L" to an 11, and it all seems to work now. Why it wants it this way i have no clue, but it works.
I always do it like this.
Sub FindingLastRow()
'PURPOSE: Different ways to find the last row number of a range
'SOURCE: www.TheSpreadsheetGuru.com
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
'Ctrl + Shift + End
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'Using UsedRange
sht.UsedRange 'Refresh UsedRange
LastRow = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row
'Using Table Range
LastRow = sht.ListObjects("Table1").Range.Rows.Count
'Using Named Range
LastRow = sht.Range("MyNamedRange").Rows.Count
'Ctrl + Shift + Down (Range should be first cell in data set)
LastRow = sht.Range("A1").CurrentRegion.Rows.Count
End Sub
https://www.thespreadsheetguru.com/blog/2014/7/7/5-different-ways-to-find-the-last-row-or-last-column-using-vba
I want to clear all cells in my worksheet from first used to last used row in my selected column, but first I must know the first used row in my selected column. How can I find the first row in "X" column? (X may = {A, B, C, ...})
Try
firstUsedRow = Worksheets("Sheet1").Cells(1, 1).End(xlDown).Row
Where the second argument in Cells(1, 1) is the column number (e.g., A=1, B=2, etc.). Sheet1 is the worksheet name of the worksheet in question.
It is possible, though unlikely in your case, that the first row is row 1. In this case, the above code will actually select your last row of the used range. As a safety measure for this case, identify the last row and make sure your first row is either 1 or the row generated by the above code. So
finalRow = Worksheets("Sheet1").Cells(Worksheets("Sheet1").UsedRange.Rows.Count, 1).End(xlUp).Row
if finalRow = firstUsedRow then
firstUsedRow = 1
End If
All together
firstUsedRow = Worksheets("Sheet1").Cells(1, 1).End(xlDown).Row
finalRow = Worksheets("Sheet1").Cells(Worksheets("Sheet1").UsedRange.Rows.Count, 1).End(xlUp).Row
if finalRow = firstUsedRow then
firstUsedRow = 1
End If
Kindly see the code below. It will skip over all the blank rows in column A represented by second argument of Cells as 1. Then assign the row positions for variables firstRow and lastRow. Last clear the values from that range.
Sub ClearCells()
Dim i As Integer
Dim firstRow As Integer
Dim lastRow As Integer
i = 1
Do While Cells(i, 1) = ""
i = i + 1
Loop
firstRow = i
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(firstRow, 1), Cells(lastRow, 1)).ClearContents
End Sub
See below with no loop.
Sub ClearCells()
Dim firstRow As Integer
Dim lastRow As Integer
firstRow = Cells(1, 1).End(xlDown).Row
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(firstRow, 1), Cells(lastRow, 1)).ClearContents
End Sub
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