I have several hundred cells. I want to find the latest in the grouping. For instance i have the following data:
233400-003-02
233400-002-03
233400-002-02
233400-002-01
233400-001-04
233400-001-03
233400-001-02
233400-001-01
The last number defines the revision. I want to keep only the greatest number or the latest revision. so far I have
For j = 9 To i Step 1
Dim Idstring As String
If Len(Cells(j, 1)) = 13 Then
Idstring = Left(Cells(j, 1), 10)
Cells(j, 5) = Idstring
ElseIf Len(Cells(j, 1)) = 16 Then
Idstring = Left(Cells(j, 1), 10)
Cells(j, 5) = Idstring
ElseIf Len(Cells(j, 1)) = 17 Then
Idstring = Left(Cells(j, 1), 14)
Cells(j, 5) = Idstring
ElseIf Len(Cells(j, 1)) = 20 Then
Idstring = Left(Cells(j, 1), 14)
Cells(j, 5) = Idstring
End If
If Cells(j, 5) = Cells(j - 1, 5) Then
If Len(Cells(j, 1)) = 16 Then
Cells(j, 5).EntireRow.Delete
ElseIf Len(Cells(j, 1)) = 20 Then
Cells(j, 5).EntireRow.Delete
ElseIf Right(Cells(j, 1), 1) < Right(Cells(j + 1, 1), 1) Then
Cells(j, 5).EntireRow.Delete
ElseIf Right(Cells(j, 1), 1) > Right(Cells(j + 1, 1), 1) Then
Cells(j + 1, 5).EntireRow.Delete
j = j + 1
End If
End If
Next j
What am I doing wrong? Thank you for your help.
I think your comparing to Cells(j-1) before you fill Cells(j-1). But if I'm wrong about that, you need to loop backward through the range when you delete rows or Excel loses track of where you are.
Public Sub DeleteAllButLatest()
Dim i As Long
For i = 9 To 3 Step -1
If Base(Cells(i, 1).Value) = Base(Cells(i - 1, 1).Value) Then
Cells(i, 1).EntireRow.Delete
End If
Next i
End Sub
Public Function Base(ByVal sCode As String) As String
Select Case Len(sCode)
Case 13, 17
Base = Left(sCode, Len(sCode) - 3)
Case 16, 20
Base = Left(sCode, Len(sCode) - 6)
End Select
End Function
Based on your sample data in A2:A9. Only need to go to Row 3 because Row 2 will have to be good so no need to check it. I made a function to return the "base" of each number so you can compare the base of the current cell to the cell above it. If they're the same, delete. If not, assume it's the latest.
Related
Private Sub CommandButton1_Click()
Dim nbp As Long
Dim i As Long
Dim p As Long
Dim FV As Variant
Dim CS As Variant
Dim K As Variant
Dim iFV As Integer
Dim iCS As Double
If Range("B9") = "Semi-Annual" Then
p = DateDiff("yyyy", Cells(4, 3), Cells(5, 3))
nbp = p * 2
For i = 5 To nbp + 4
Cells(5, 10).Value = Cells(4, 3).Value
Cells(i + 1, 10).Value = DateAdd("m", 6, Cells(i, 10).Value)
Next i
For i = 6 To nbp + 5
Cells(i, 14).Value = Cells(7, 2).Value * (Cells(8, 2).Value / 2)
Next i
FV = Sheet2.Range("J5:J10").Value
CS = Sheet3.Range("F1:G8000").Value
For iFV = 1 To UBound(FV)
For iCS = 1 To UBound(CS, 2)
If FV(iFV, 1) = CS(iCS, 1) Then
K(iFV, 1) = CS(iCS, 2)
End If
Next
Next
Sheet2.Range("K5:K10").Value = K
End If
End If
If Range("B9") = "Annual" Then
nbp = DateDiff("yyyy", Cells(4, 3), Cells(5, 3))
For i = 5 To nbp + 4
Cells(5, 10).Value = Cells(4, 3).Value
Cells(i + 1, 10).Value = DateAdd("m", 12, Cells(i, 10).Value)
Next i
End if
If Range("B9") = "Quarterly" Then
p = DateDiff("yyyy", Cells(4, 3), Cells(5, 3))
nbp = p * 4
For i = 5 To nbp + 4
Cells(5, 10).Value = Cells(4, 3).Value
Cells(i + 1, 10).Value = DateAdd("m", 3, Cells(i, 10).Value)
Next i
End If
If Range("B9") = "Monthly" Then ' to choose from a list .
p = DateDiff("yyyy", Cells(4, 3), Cells(5, 3))
nbp = p * 12
For i = 5 To nbp + 4
Cells(5, 10).Value = Cells(4, 3).Value
Cells(i + 1, 10).Value = DateAdd("m", 3, Cells(i, 10).Value)
Next i
End If
End Sub
I have added all the code in the button to help. i am not sure if that will help, anyway here is it. if the user chooses semi annual then couple of things take place. Same goes for the rest "ifs" but i need to fix this issue first then move on to the rest. the code to too long, it is simple and not complicated.
Now that more of the code is posted, I think I understand what the problem is.
Wherever you reference Cells() VBA assumes it applies to ActiveSheet. And I think you should fully qualify the calls to be Sheet2.Cells() for example or whatever you need.
When you call the code behind a button, the button resides on a sheet and it references the cells on that sheet. But when you moved the code to a module it no longer referenced the sheet with the button, but whatever other sheet was active at the time.
So whenever you see Cells() or Range() without a worksheet specification in front of it, change it so that it you target a specific worksheet.
PS. Avoid using Integer and prefer Long instead. Also, prefer relative referencing such as Sheet2.Range("G2").Cells(i,j) instead of absolute referencing Sheet2.Cells(1+i, 6+j) or string math such as Sheet2.Range("G" & 1+i & ":G" & 5+i).
i have a rather large code, which started small but as the variables kept coming so did the code.
my first "problem" is this part:
If (Cells(k, 5) = buafd1 Or Cells(k, 5) = buafd2 Or Cells(k, 5) = buafd3 _
Or Cells(k, 5) = buafd4 Or Cells(k, 5) = buafd5 Or Cells(k, 5) = buafd6 Or Cells(k, 5) = buafd7 _
Or Cells(k, 5) = buafd8 Or Cells(k, 5) = buafd9 Or Cells(k, 5) = buafd10 Or Cells(k, 5) = buafd11 _
Or Cells(k, 5) = buafd12 Or Cells(k, 5) = buafd13) And Cells(k, 6) = LCSPnavn1 Then
Amount = Cells(k, 13)
LCSPsum1 = LCSPsum1 + Amount
as you can see the cell that i look at is the same, but i am checking it against a list of variables which is a criteria for the sum function to be activated
the next thing is that i have alot of "LCSPsums"
like this:
'LCSPsum 2
ElseIf (Cells(k, 5) = buafd1 Or Cells(k, 5) = buafd2 Or Cells(k, 5) = buafd3 _
Or Cells(k, 5) = buafd4 Or Cells(k, 5) = buafd5 Or Cells(k, 5) = buafd6 Or Cells(k, 5) = buafd7 _
Or Cells(k, 5) = buafd8 Or Cells(k, 5) = buafd9 Or Cells(k, 5) = buafd10 Or Cells(k, 5) = buafd11 _
Or Cells(k, 5) = buafd12 Or Cells(k, 5) = buafd13) And Cells(k, 6) = LCSPnavn2 Then
Amount = Cells(k, 13)
LCSPsum2 = LCSPsum2 + Amount
'LCSPsum 3
ElseIf (Cells(k, 5) = buafd1 Or Cells(k, 5) = buafd2 Or Cells(k, 5) = buafd3 _
Or Cells(k, 5) = buafd4 Or Cells(k, 5) = buafd5 Or Cells(k, 5) = buafd6 Or Cells(k, 5) = buafd7 _
Or Cells(k, 5) = buafd8 Or Cells(k, 5) = buafd9 Or Cells(k, 5) = buafd10 Or Cells(k, 5) = buafd11 _
Or Cells(k, 5) = buafd12 Or Cells(k, 5) = buafd13) And Cells(k, 6) = LCSPnavn3 Then
Amount = Cells(k, 13)
LCSPsum3 = LCSPsum3 + Amount
all the way to 28 xD
it is working but i am now trying to put more "buafd" on which is a pretty slow process since i have to add 7 times "cells(k,5) = buafd..." 28 times.
Does someone have a smart solution that might also make it work faster?
regards
Niklas
First I would put your variables in an array. This way when you need to increase the number of these variables you can just increase the size of your array.
Dim oBuafd(12) As String
Dim oLCSPnavn(27) As Double
Dim oLCSPsum(27) As Double ' or you could do a multi-dimensional array with oLCSPnavn
Function to search array and return true if it found the value
Private Function InList(ByVal SearchValue As String, ByRef List() As String) As Boolean
InList = False
Dim oCounter As Integer
For oCounter = 0 To UBound(List)
If StrComp(SearchValue, List(oCounter), vbTextCompare) = 0 Then
InList = True
Exit For
End If
Next
End Function
This would be the code to replace all your repeated steps. If amount is just being used at this point and serves no other function then you don't need it, you can apply the amount directly to oLCSPnavn.
Dim Amount As Double
Dim oCounter As Integer
For oCounter = 0 To UBound(oLCSPnavn)
If InList(Sheet1.Cells(11, 5), oBuafd) And oLCSPnavn(oCounter) = Sheet1.Cells(11, 6) Then
Amount = Sheet1.Cells(11, 13)
oLCSPsum(oCounter) = oLCSPsum(oCounter) + Amount ' Is this all your doing with amount or does it have another purpose?
End If
Next
The code below is taken from the link Similar values in range make it as a KEY and sum function, however, I have made small adjustments to it (adding more cells to be checked). What the code does, is to check if columns 4, 5, 8, 36 and 37 have similar values/text in their cells. If yes, then it looks in column 59 and uses the sum function to check if the values of the similar entries are less or higher than 100. If yes, then the cells in column 59 turn red, if not, they should remain white.
Example:
Column 4: Cell D5, D6 and D7 - all are P11
Column 5: Cell E5, E6 and E7 - all are P12
Column 8: Cell H5, H6 and H7 - all are P13
Column 36: Cell AJ5, AJ6 and AJ7 - all are P14
Column 37: Cell AK5, AK6 and AK7 - all are P15
Column 59: Cell BG5 = 40 and BG6 = 20 and BG7 = 30. Total value: 90 which does not equal 100. Henceforth, BG5, BG6 and BG7 must turn red. (the sum function works only when the other columns mentioned have similar value in their rows)
The code worked when it was checking only the columns 4, 5 and 8 and no error was received. However, after I added also the columns 36 and 37, the following error is received: Unable to get the interior property of the range class - Run time error 1004 and I don't know how to solve this.
Note: The columns 4, 5, 8, 36, 37 and 59 also have the conditional formatting formula isblank to turn the cells red if they are empty. The reason for that is because people need to know that those cells are mandatory to complete.
Thanks for your help and time!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, j As Long, sum1 As Long, k As Long, c(5000) As Long
Application.EnableEvents = False
Range("bg5:bg5000").Interior.Color = RGB(255, 255, 255)
For i = 5 To 4999
k = 0
For j = i + 1 To 5000
If Cells.Interior.Color <> RGB(255, 0, 0) Then
If Cells(i, 4) & Cells(i, 5) & Cells(i, 8) & Cells(i, 36) & Cells(i, 37) <> "" Then
If Cells(i, 4) = Cells(j, 4) And Cells(i, 5) = Cells(j, 5) And Cells(i, 8) = Cells(j, 8) And Cells(i, 36) = Cells(j, 36) And Cells(i, 37) = Cells(j, 37) Then
If k = 0 Then sum1 = Cells(i, 59): k = 1: c(k) = i
sum1 = sum1 + Cells(j, 59)
k = k + 1
c(k) = j
End If
End If
End If
Next j
If sum1 <> 100 Then
For j = 1 To k
Cells(c(j), 59).Interior.Color = RGB(255, 0, 0)
Next j
End If
Next i
Application.EnableEvents = True
End Sub
here a proposal to adapt the code. Note that the macro runs each time you enter a value in column 59 and that it executes the code insides the loop for about 2500000 times, this may take some time.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, j As Long, sum1 As Long, k As Long, c(5000) As Long
If Target.Column <> 59 Then Exit Sub
Application.EnableEvents = False
Range("bg5:bg5000").Interior.Color = RGB(255, 255, 255)
For i = 5 To 4999
k = 0
If Cells(i, 4) & Cells(i, 5) & Cells(i, 8) & Cells(i, 36) & Cells(i, 37) <> "" Then
If Cells(i, 59).Interior.Color <> RGB(255, 0, 0) Then
For j = i + 1 To 5000
If Cells(j, 59).Interior.Color <> RGB(255, 0, 0) Then
If Cells(j, 4) & Cells(j, 5) & Cells(j, 8) & Cells(j, 36) & Cells(j, 37) <> "" Then
If Cells(i, 4) = Cells(j, 4) And Cells(i, 5) = Cells(j, 5) And Cells(i, 8) = Cells(j, 8) And Cells(i, 36) = Cells(j, 36) And Cells(i, 37) = Cells(j, 37) Then
If k = 0 Then sum1 = Cells(i, 59): k = 1: c(k) = i
sum1 = sum1 + Cells(j, 59)
k = k + 1
c(k) = j
End If
End If
End If
Next j
If sum1 <> 100 Then
For j = 1 To k
Cells(c(j), 59).Interior.Color = RGB(255, 0, 0)
Next j
End If
End If
End If
Next i
Application.EnableEvents = True
End Sub
code adapted, if you want to link it to a button, add a button, right-click on the button and assign this macro (aargh) to it.
Sub aargh()
Dim i As Long, j As Long, sum1 As Long, k As Long, c(5000) As Long, fl(5000) As Boolean
Dim s1 As String, s2 As String
Range("bg5:bg5000").Interior.Color = RGB(255, 255, 255)
For i = 5 To 4999
k = 0
s1 = Cells(i, 4) & Cells(i, 5) & Cells(i, 8) & Cells(i, 36) & Cells(i, 37)
If s1 <> "" Then
If Not fl(i) Then
For j = i + 1 To 5000
If Not fl(j) Then
s2 = Cells(j, 4) & Cells(j, 5) & Cells(j, 8) & Cells(j, 36) & Cells(j, 37)
If s2 <> "" Then
If s1 = s2 Then
If k = 0 Then sum1 = Cells(i, 59): k = 1: c(k) = i: fl(i) = True
sum1 = sum1 + Cells(j, 59)
k = k + 1
c(k) = j
fl(j) = True
End If
End If
End If
Next j
If sum1 <> 100 Then
For j = 1 To k
Cells(c(j), 59).Interior.Color = RGB(255, 0, 0)
Next j
End If
End If
End If
Next i
End Sub
I need to copy a lot of rows. I tried to do something.copy something else.paste but it's extremely slow
I tried to do
Range(..).value(formula) = Range(..).value(formula) but its not so good because i have a date there that turn to ######
I need a faster way to do this copy/paste
This is my code:
Function Last_Col(k As Long) As Long
Last_Col = Cells(k, Columns.Count).End(xlToLeft).Column
End Function
Function Last_Col_Doc() As Long
Last_Col_Doc = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Column
End Function
Function Is_Grouped(i As Long) As Boolean
Is_Grouped = (Cells(i, 2).Rows.OutlineLevel > 1)
End Function
Function Is_Bold(i As Long) As Boolean
Is_Bold = Cells(i, 2).Font.Bold
End Function
Function Print_NA(i As Long, k As Long) As Boolean
Range(Cells(i, 21), Cells(i, 21 + k - 2)).Value = "NA"
End Function
Function Last_Row() As Long
Last_Row = Cells(Rows.Count, "B").End(xlUp).Row
End Function
Sub EditParanoia()
Dim FrstBlkRow As Long
Dim flag As Boolean
Dim i As Long
Dim HeadLen As Long
FrstBlkRow = Last_Col(1) + 1
If FrstBlkRow < 25 Then 'first edit
flag = True
i = 2
Do While flag
If Is_Bold(i) Then
flag = False
Else
i = i + 1
End If
Loop
HeadLen = Last_Col(i)
Range(Cells(i, 2), Cells(i, HeadLen)).Copy
Range(Cells(1, FrstBlkRow), Cells(1, FrstBlkRow + HeadLen - 2)).PasteSpecial
Else
FrstBlkRow = 21
HeadLen = 10
End If
Dim j As Long
For i = 2 To Last_Row Step 1
If Not Is_Grouped(i) And Not Is_Grouped(i + 1) And Cells(i, FrstBlkRow + 1).Value = vbNullString Then
'if not part of group
Range(Cells(i, FrstBlkRow), Cells(i, FrstBlkRow + HeadLen - 2)).Value = "NA"
ElseIf Not Is_Grouped(i) And Is_Grouped(i + 1) And Is_Grouped(i + 2) And Not Is_Grouped(i + 3) Then
'if Part of group of 1 val
Range(Cells(i + 2, 2), Cells(i + 2, 2 + HeadLen - 2)).Copy
Range(Cells(i, FrstBlkRow), Cells(i, FrstBlkRow + HeadLen - 3)).PasteSpecial
ElseIf Not Is_Grouped(i) And Is_Grouped(i + 1) Then
'if part of group of more then one val
j = 1
Do Until Is_Grouped(i + j) And Not Is_Grouped(i + j + 1)
'j will get the langth of any group
j = j + 1
Loop
'past the relevant cell in the right place
Range(Cells(i + 2, 2), Cells(i + 2 + j - 1 - 1, 2 + HeadLen - 2)).Copy
Range(Cells(i, FrstBlkRow), Cells(i + j - 1 - 1, FrstBlkRow + HeadLen - 3)).PasteSpecial
'past the head respectively
Range(Cells(i, 1), Cells(i, 20)).Copy
Range(Cells(i + 1, 1), Cells(i + j - 2, FrstBlkRow - 1)).PasteSpecial
End If
Next
End Sub
When you say you've tried "Range(..).value(formula) = Range(..).value(formula)", what do you mean? You should be able to set two ranges equal to eachother:
Say A1:A10 has "Batman, 10-01-2015" and you want to copy that range to B1:B10, Range("B1:B10").Value = Range("A1:A10").Value. You can't do that? I tried it with dates, and it set the B range values to dates, no reformatting necessary.
I also notice in your code, you PasteSpecial, but don't specify what type of special paste. See the Microsoft (or this one) page for more info.
The below is a snippet of the code I'm using. I'm having a problem with how I need to name j. I need it to be 3,4,5,6 for the first tab_name and then 7,8,9,10 for the next and 11,12,13,14 for the one after that etc.
Can I improve the way I've attempted below?
tab_names = Array("11EB", "11WB", "12EB", "12WB", "13EB", "13WB", "14EB")
Location = Array(3, 7, 11)
For Each indiv_tab In tab_names
For Each j In Location
For i = 9 To 24
Sheets("Front Page").Cells(2, 2) = Cells(i, 1)
Cells(i, j) = Sheets(indiv_tab).Cells(2993, 9)
Cells(i, j + 1) = Sheets(indiv_tab).Cells(2993, 22)
Cells(i, j + 2) = Sheets(indiv_tab).Cells(2993, 35)
Cells(i, j + 3) = Sheets(indiv_tab).Cells(2993, 48)
Next i
Next j
Next
EDIT
I'm now using the below code, however, I need it go Next tab_name and Next j at the same time. Is there anyway to do this?
tab_names = Array("11EB", "11WB", "12EB", "12WB", "13EB", "13WB", "14EB", "14WB", "15NB", "15SB", "16NB", "16SB", "17EB", "17WB", "18EB", "18WB", "19NB", "19SB", "20NB", "20SB", "21NB", "21SB", "22NB", "22SB", "23NB", "23SB", "24NB", "24SB", "25NB", "25SB", "26NB", "26SB", "27EB", "27WB", "28EB", "28WB", "29EB", "29WB", "30EB", "30WB", "31NB", "31SB", "32NB", "32SB", "33EB", "33WB", "34EB", "34WB", "35NB", "35SB", "36NB", "36SB", "37EB", "37WB", "38NB", "38SB", "39NB", "39SB", "40EB", "40WB", "41EB", "41WB", "A12NB", "A12SB", "M11NB", "M11SB", "M25NB", "M25SB", "A120EB", "A120WB", "A120AEB", "A120AWB")
For i = 9 To 24
For Each indiv_tab In tab_names
For j = 3 To 291 Step 4
Sheets("Front Page").Cells(2, 2) = Cells(i, 1)
Cells(i, j) = Sheets(indiv_tab).Cells(2993, 9)
Cells(i, j + 1) = Sheets(indiv_tab).Cells(2993, 22)
Cells(i, j + 2) = Sheets(indiv_tab).Cells(2993, 35)
Cells(i, j + 3) = Sheets(indiv_tab).Cells(2993, 48)
Next j
Next
Next i
Thanks for any help.
Do you mean you want j to iterate through 3, 4, 5, 6 on the first tab, then 7, 8, 9, 10 on the second etc...?
If so, the below should work. Start with location as I've specified (declare as a new variable if you use it elsewhere), then manually adjust it each time.
tab_names = Array("11EB", "11WB", "12EB", "12WB", "13EB", "13WB", "14EB")
Location = Array(3, 4, 5, 6) '##changed this
For Each indiv_tab In tab_names
For Each j In Location
For i = 9 To 10
Sheets("Front Page").Cells(2, 2) = Cells(i, 1)
Cells(i, j) = Sheets(indiv_tab).Cells(2993, 9)
Cells(i, j + 1) = Sheets(indiv_tab).Cells(2993, 22)
Cells(i, j + 2) = Sheets(indiv_tab).Cells(2993, 35)
Cells(i, j + 3) = Sheets(indiv_tab).Cells(2993, 48)
Next i
Next j
'adjust values on each loop
For i = 0 To UBound(Location, 1)
Location(i) = Location(i) + 4
Next i
Next