I'm trying to transfer information from a large matrix into a different report and this code works when I go step by step but it gets stuck in an infinite loop when I let it run without a break. Hoping to get some help if possible!
more context: Im trying to seek the information in a matrix in a different work sheet, copy information in the corresponding rows and columns, and then paste back into the original sheet with the referenced cell it is seeking
For k = 2 To 600
mpn = inbox.Cells(k, 3).value
If Not IsEmpty(mpn) = True Then
i = 1
j = 1
For j = 8 To 50
For i = 23 To 1000
mpnsearch = wshmatrix.Cells(i, j).value
If mpnsearch = mpn Then
color = wshmatrix.Cells(9, j).value
mpncolor = Right(color, 1)
inbox.Cells(k, 5).value = mpncolor
End If
Next i
Next j
End If
Next k
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
End Sub
If I understand your code correctly, you have a column of values in index, and you need to search each of these mpn in a 2D matrix wshmatrix. The return value mpncolor is in the same column but in the 9th line, above your search matrix.
If you had formatted this as a lookup table (all possible mpn values in column 1, all mpncolors in column 2), this could be solved without VBA, with VLOOKUP().
You can build this search table in VBA, if it is reasonably static.
If it changes frequently, you can use a Collection object:
Dim lookuptbl as New Collection
For j = 8 To 50
For i = 23 To 1000
lookuptbl.Add item := Right(wshmatrix.Cells(9, j).value, 1), _
key := CStr(wshmatrix.Cells(i, j).value)
Next
Next
For k = 2 To 600
mpn = inbox.Cells(k, 3).value
inbox.Cells(k, 5).value = lookuptbl.Item(CStr(mpn))
Next
I did not test it right now, but I think you can get the idea.
Related
I have two tables. One table is called DRData (Blad3), other table is CheckData (Blad2). EANCODE is Column J for DRData, and Column A for Checkdata.
I want to check whether CheckData.EANCODE is present in DRData.EANCODE. If so; delete that row from CheckData.
I tried several things, but no success yet. The code I have written now is as follows:
Sub FindEAN()
Dim i As Long
Dim x As Long
x = 1 'Start on first row
EANtoFind = Blad2.Range("A" & x).Value
For i = 1 To 99999 '
If Blad3.Cells(i, 1).Value = EANtoFind Then
Blad2.Range("A" & x).EntireRow.Delete
Else: x = x + 1
End If
Next i
End Sub
When the EANCODE is not present, I want to hop over a row to check that code. I want to end with a list in CheckData where all the EANCODE values that are not in DRData are shown.
With the code above, only the first row is getting deleted and now I'm stuck how to get this to loop. Including the x+1 to get to the next row.
First you have to clarify that your problem is a little bit complicated. You have to pay attention to indexes when deleting rows
To do that, you have to point the the maximal number of line to optimize your loop
A simple way to do that, is to use predefined search function, and edit your code a little bit.
My favorite is Application.match(), which takes 3 parameters :
Value to look for
Array where you look (in our case the column J of Blad3 or position 10)
0 : exact match
For more details, see the documentation
https://learn.microsoft.com/fr-fr/office/vba/api/excel.worksheetfunction.match
An example of code which works is like the following
Sub FindEAN()
Dim x As Long
x = 1 'Start on first row
maxline = Blad2.Range("A" & Rows.count).End(xlUp).row
While x <= maxline '
EANtoFind = Blad2.Range("A" & x).Value
If Not IsError(Application.Match(EANtoFind, Blad3.Columns(10), 0)) Then
Blad2.Range("A" & x).EntireRow.Delete
maxline = maxline - 1
Else
x = x + 1
End If
Wend
End Sub
I have the need to automatic create report that is based on the dates and portfolios.
For example if I put 2 dates and 2 portfolios like this
The report should look like this:
So if we enter 3 dates and 4 portfolios the report should have 3 tables and each one has 4 portfolios...
I'm ok to do it manual but it is ideally to be automatic,(I think it can be done through VBA, but not quite sure about it) can you guys help? Thank you.
You have to to move your data from where is stored to the Project sheet.
I guess that the date doesn't make any different on the portfolio, isn't it?
If so, it's quite easy. I don't know how your data is stored, but let's guess it's equal as shown it your screenshot.
Option Base 1 'array will start at 1 instead of 0
Public Setting As Worksheet, ListPortfolios As Worksheet, Project As Worksheet
Public RangeSelectDates As Range, RangeSelectPortfolios As Range, RowOfCodePortfolios As Range
Public ArraySelectDates(), ArraySelectPortfolios(), ArrayOfCodePortfolios(), ArrayPortfolio(), ArrayProject()
Public PortfolioCode$
Dim i%, j%, k%, r%, c%
Sub Automate()
Set Setting = Worksheets("Setting")
Set ListPortfolios = Worksheets("ListPortfolios")
Set Project = Worksheets("Project")
'First, read the portfolio code and dates to import and store in array
With Setting
Set RangeSelectDates = .Cells(4, 5).CurrentRegion
Set RangeSelectPortfolios = .Cells(4, 8).CurrentRegion
End With
ArraySelectDates = RangeSelectDates
ArraySelectPortfolios = RangeSelectPortfolios 'store the range in a Array
ReDim ArrayProject(1 To 24, 1 To 1)
'Now, create an array with the names of the portfolios where you have stored them. I don't know how your data is stored.
'I assume you've got it as the Project sheet result it's shown and also at "ListPortfolios" sheet
With ListPortfolios
Set RowOfCodePortfolios = .Rows(5)
End With
ArrayOfCodePortfolios = RowOfCodePortfolios 'store the row in a Array
k = 0 'means no value is found
For i = LBound(ArraySelectPortfolios) To UBound(ArraySelectPortfolios) 'Navigate to all the Portfolios Selected
'the portfolio codes are stored in the "second column" of the array, say PortfolioCode is the name of the portfolio
PortfolioCode = ArraySelectPortfolios(i, 2)
For j = LBound(Application.Transpose(ArrayOfCodePortfolios)) To UBound(Application.Transpose(ArrayOfCodePortfolios)) 'now navigate to where your portfolios are stored
If ArrayOfCodePortfolios(1, j) = PortfolioCode Then 'if match, create a new array with the whole portfolio
With ListPortfolios
ArrayPortfolio = .Range(.Cells(1, j), .Cells(24, j + 2)) 'I don't know the size of your data. I assume that the first column is the same of where the portfoliocode is stored and its size is 24 rows x 3 columns
End With
'now, copy it to the Project Portfolio
ReDim Preserve ArrayProject(1 To 24, 1 To 3 + k * 3)
For r = 1 To 24 'from the r (row) one to 24th. I don't know how your data is stored
For c = 1 To 3 'from the column 1 to the 3rd of each portfolio
ArrayProject(r, c + k * 3) = ArrayPortfolio(r, c) 'built the result for each portfolio found
Next c
Next r
k = k + 1 'one value is found, let's go for the next one if so
End If
Next j
Next i
If k <> 0 Then 'if any value is found then
For i = 1 To UBound(ArraySelectDates) 'let's place the date and print to the excel
ArrayProject(2, 1) = ArraySelectDates(i, 2) 'paste the date into the array
With Project
.Range(.Cells(1, 4 + 1 + (i - 1) * k), .Cells(24, UBound(Application.Transpose(ArrayProject)) + 3 + (i - 1) * k)) = ArrayProject 'print the array
'1+(i-1)*k is the first column + which date are we copying times portfolio codes found
End With
Next i
End If
End Sub
There's no error handling, either if there aren't input values may crash. But first, make it work
I am trying to find the first four cells along a row that contain values and the type is Double. I want to add the values of the cells to an array and also locate the cells locations for future use. I need to work down 23 rows after as well. Some of the rows don't contain any values. The matrix starts with cell AB3
I've been trying to start with a For loop so I can work down the rows and then having a For loop inside that to create a new array every time I move to a new row.
The code I need looks something like this.
For i = 3 to 27
For j = 0 to 3
TIGA(j) = Range(Cells(i, j + 28), Cells(last cell)).Find(first
value and then the next three)
Again I need to work across from left to right in each row. First I need to add the first four values in a row to an array. Next I need to save the column number for each of the values because I need to know what column they're in later on in my code. After I get the information for one your I need to loop it down for the rest. The array with the values and any variable/array used for the cells location can be restarted every time the code loops through for the new row. Thank you!
Here's what's the data looks like.
I changed things up a bit, I think this should suffice:
Sub Test()
Dim TIGA As Variant, i As Long, j As Long, k As Long
ReDim TIGA(0 To 3)
For i = 3 To 27
k = 0
For j = 28 To 40
If Cells(i, j) <> "" Then
If IsNumeric(Cells(i, j)) = True And InStr(Cells(i, j), ".") > 0 Then 'make sure it's a double
TIGA(k) = Cells(i, j)
k = k + 1
If k = 3 Then
Exit For
End If
End If
End If
Next j
Next i
End Sub
I have an excel spreadsheet. In a column of the spreadsheet I have a list of codes (numbers).These codes (numbers) are sorted from highest to lowest values.(some of these codes has been repeated. For example I have three consecutive line with code 1001200).I want to insert new rows between each codes (in case of having repeated codes i just need one new row (for example i Just need one new row for 1001200 not 3 rows) .
I have written the following code but it does not work.
Sub addspace()
Dim space_1(5000), Space_2(5000)
For n = 1 To 5000
Debug.Print space_1(n) = Worksheets("sheet3").Cells(1 + n, 1).Value
Debug.Print Space_2(n) = Worksheets("sheet3").Cells(2 + n, 1).Value
Next
For n = 1 To 5000
If space_1(n) <> Space_2(n) Then
Range("space_1(n)").EntireRow.Insert
End If
Next
End Sub
How can I fix it? (From the code you can see that I am so beginner :)))
Cheers
To insert one empty row between each unique value try this:
Option Explicit
Public Sub addspace()
Dim i As Long
Application.ScreenUpdating = False
With Worksheets("sheet3")
For i = 5000 To 2 Step -1
While .Range("A" & i - 1) = .Range("A" & i)
i = i - 1
Wend
.Rows(i).Insert Shift:=xlDown
Next
End With
Application.ScreenUpdating = True
End Sub
It starts from the end row and moves up, skipping duplicates
The Range("space_1(n)") is invalid. Arg of range object should be a column name like "A1", you can use Range("A" & n).EntireRow.Insert in your code. But I recommend my code.
Please try,
Sub addspace()
Dim n As Integer
For n = 1 To 5000
If Worksheets("sheet3").Cells(n, 1).Value <> Worksheets("sheet3").Cells(n + 1, 1).Value Then
Worksheets("sheet3").Cells(n + 1, 1).EntireRow.Insert
n = n + 1
End If
Next
End Sub
The code I have once worked to add/delete groups of rows (requirements). I needed to modify the code so that if the 1st row of the group met certain criteria (i.e, the requirement was not one we wanted to consider), (1) we would not count it and (2), we would hide the group (current and subsequent 2 rows). This all works fine.
The problem is that now that I incorporated these changes, I get an error in another section of the code and for the life of me I cannot figure out why. I have stepped through this and am extremely frustrated. I am reaching out for help, and am hoping someone can see my error(!)
We calculate the start and finish row numbers within a grouping, and store these calculations in Arrays called "Start" and "Finish." I use the ReDim statement to initialize my arrays, because I thought that could be part of the problem, but no.
Any insight as to why my "subscripts are out of range" would be appreciated. I have traced through the logic, investigated this error, and read about the syntax/usage of VBA arrays. I don't know what else to do. Thanks in advance. Here are the relevant lines:
Sub Button1_Click()
Cells.Select
Selection.ClearOutline
If Cells.EntireRow.Hidden Then Cells.EntireRow.Hidden = False
Dim Start() As Integer
Dim Finish() As Integer
Dim p As Integer, q As Integer
ReDim Start(0, 50)
ReDim Finish(0, 50)
The following is embedded in logic that loops through all the rows in the spreadsheet:
i = 1
For Row = 4 To Cells(1, 6).Value - 1
If Begin Then
If Cells(Row, 3).Interior.ColorIndex = 44 Then
Start(i) = Row + 1
j = Cells(Row, 2).Value
Begin = False
End If
Else
If Cells(Row, 2).Value = j + 1 Or Cells(Row, 2).Interior.ColorIndex = 37 Then
Finish(i) = Row - 1
Begin = True
i = i + 1
Row = Row - 1
End If
End If
Next
The block I changed is as follows (code I added is last block where I attempt to hide rows). It precedes the previous. I am wondering how my change could have affect the above(?!)
If Cells(Row, 5).Value = "Requirement" Then
Range(Cells(Row, 4), Cells(Row, 4)).Interior.ColorIndex = 40
Rows(Row).Font.Bold = True
Rows(Row).Font.Italic = False
Rows(Row).Font.ColorIndex = 1 'Black
If Cells(Row - 3, 4).Value = "" Then 'this is requirement #1
Cells(Row, 4).Value = 1
Else
Cells(Row, 4).Value = Cells(Row - 3, 4).Value + 1
End If
p = Row
q = p + 2
Rows(p & ":" & q).Select
If Cells(p, 19).Value = "4" Then
Selection.EntireRow.Hidden = True
Else
Selection.EntireRow.Hidden = False
End If
Redim Start(0,50) makes the array dimensions 0 to 0, 0 to 50 i.e. a 2d array.
This means that when you call the array you need to provide parameters for both dimensions I.E: Start(0,i) or Finish(0,i). Calling Start(i) will result in the error you mentioned.
The easiest way to get rid of the error is to change your Redim lines to
ReDim Start(50)
ReDim Finish(50)
which is what I assume you meant to do in the first place.
Note: Based upon the format you used, you may have been meaning to do Start(0 to 50) and Finish(0 to 50) initially. The comma in the dimensioning indicates another dimension instead of a separation between lower and upper bounds.