Problem:
I have a code that does everything it should, only it does not 'finish' its work. Whenever I run this code, it seems that the last 2 rows are not included.
Code:
Sub List()
Dim sStDev As Worksheet: Set sStDev = Sheets("StDev")
Dim sResult As Worksheet: Set sResult = Sheets("Large")
Dim sQuart As Worksheet: Set sQuart = Sheets("Quintile")
Dim sReturn As Worksheet: Set sReturn = Sheets("Return")
Dim j As Long
Const colDate As Long = 1
Const rowStDevFirst As Long = 2
Const rowResultFirst As Long = 2
Dim LastRow As Long
LastRow = sReturn.Cells(Rows.Count, "A").End(xlUp).Row
Dim rowResult As Long: rowResult = rowResultFirst
j = 2
Dim i As Long: For i = rowStDevFirst To LastRow
Dim colResult As Long: colResult = 1
sResult.Cells(rowResult, colResult).Value = sStDev.Cells(i, colDate).Value
colResult = colResult + 1
For j = 1 To 792
If sStDev.Cells(i, j).Value >= sQuart.Range("F2").Offset(i, 0) And sStDev.Cells(i, j).Value <= sQuart.Range("G2").Offset(i, 0) Then
sResult.Cells(rowResult, colResult).Value = sReturn.Cells(i, j).Value
colResult = colResult + 1
End If
Next j
rowResult = rowResult + 1
Next i
MsgBox "Listed"
End Sub
How can I make this code include my last two rows as well?
Thank you in advance!
File: File
As I see you try to fill out the Large sheet with these values from Return sheet for which the corresponding value in StDev is between F and G values in Quintile for each row.
It's Ok, but you shouldn't offset the values in Quintile by i as even for the second row you get the Quintile!F4 and G4 instead of F2 and G2.
So to fix it you should change sQuart.Range("F2").Offset(i, 0) to sQuart.Range("F2").Offset(i-2, 0)
and the same for column G: Offset(i, 0) should be Offset(i-2, 0)
Related
I am working with a schedule, that I have imported and formatted into my workbook.
I am wanting this to populate Phase in the upper listbox and then when a phase is selected the sub-task associated with those phases are displayed in the bottom listbox.
I want to use an array but I seem to be having problems when the columns are not next to each other or there are "gaps" with the blank cells.
My first attempt using assigning the Array to the currentregion worked but brought all columns and fields in. Listbox1 should contain (ID, PHASE NAME, DURATION, START DATE, FINISH DATE) List box 2 should when a Phase is selected contain the subtasks if any from the column to the right, listed before the next next Phase name. (ID, SUB-TASK NAME, DURATION, START DATE, FINISH DATE)
(See picture)
I have code but its more me trouble-shooting than an actual semi working script.
Dim shT As Worksheet
Dim schnumrng1 As Range
Dim schnumrng2 As Range
Dim schnumrng3 As Range
Dim schnumrng4 As Range
Dim schnumrng5 As Range
Dim schpersonrng As Range
Dim schphaserng As Range
Dim schlistrng As Range
Dim maxschnum
Dim schstatus
Dim schperson
Dim schlistnum
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim rng As Range
Dim cl As Range
Dim lc
'allowevents = True
''Set Screen parameters
'Application.ScreenUpdating = False
'Application.EnableEvents = False
'
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
Set schnumrng = Range("B5", "B" & maxschnum)
'Set Ranges for the list box
Set schnumrng1 = Range("A5", "A" & maxschnum)
Set schnumrng2 = Range("B5", "B" & maxschnum)
Set schnumrng3 = Range("D5", "D" & maxschnum)
Set schnumrng4 = Range("E5", "E" & maxschnum)
Set schnumrng5 = Range("F5", "F" & maxschnum)
'This is static and not moving to the next line in my for statement / switched to named ranges and errors
Set rng = schnumrng1, schnumrng2, schnumrng3, schnumrng4, schnumrng5
'Set rng = Range("A5,B5,D5,E5,F5")
i = 1
j = 1
For Each lc In schnumrng
If lc <> vbNullString Then
For Each cl In rng
ReDim Preserve Ar(1, 1 To i)
Ar(j, i) = cl.Value
i = i + 1
Next cl
Else
End If
j = j + 1
Next lc
With ScheduleForm.SchMainTasklt
.ColumnCount = i - 1
.ColumnWidths = "50;150;50;50;50"
.List = Ar
End With
My problem then is two fold, trying to use the dynamic ranges or another tool Index? collection? to populate the 1st list box. 2. How to deal with blanks and noncontiguous columns when data is not separated for organization purposes.
I don't know if I figured out your intentions well.
First, only the data in column b, not empty cells, is extracted from listbox1.
Second, when listbox1 is selected, data related to listbox2 is collected through the selected listbox value.
Module Code
Place this code in the module. This is because global variables must be used.
Public vDB As Variant
Public Dic As Object 'Dictionary
Sub test()
Dim shT As Worksheet
Dim maxschnum As Long
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim vC() As Variant
Dim cnt As Integer, n As Integer
Dim c As Integer
Dim s As String, s2 As String
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set Dic = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
With shT
vDB = .Range("a5", .Range("f" & maxschnum))
End With
'vC is data colum A,B,D,E,F
vC = Array(1, 2, 4, 5, 6)
s2 = vDB(2, 2)
For i = 2 To UBound(vDB, 1)
s = vDB(i, 2) 'column B
If s = "" Then
n = n + 1
Else
If Dic.Exists(s) Then
Else
If i > 2 Then
Dic(s2) = Dic(s2) & "," & n
End If
Dic.Add s, i
s2 = s
cnt = cnt + 1
ReDim Preserve Ar(1 To 5, 1 To cnt)
For c = 0 To UBound(vC)
Ar(c + 1, cnt) = vDB(i, vC(c))
Next c
End If
n = 0
End If
Next i
Dic(s2) = Dic(s2) & "," & n
' Records information about the data in a dictionary.
' Dic is "phase neme" is Key, Item is "2,4"
' example for KICkOFF
' dic key is "KICKOFF", Item is "5,4"
' 5 is KICOFF's row number in array vDB
' 4 is the number of blank cells related to kickoff.
With ScheduleForm.SchMainTasklt
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
'.List = Ar
.Column = Ar 'In the state that the array has been converted to row column, you can use listbox.column.
End With
End Sub
Form Code
Private Sub UserForm_Initialize()
Call test
End Sub
Private Sub SchMainTasklt_Click()
Dim s As String, sItem As String
Dim arr As Variant, vC As Variant
Dim vR() As Variant
Dim st As Long, ed As Long
Dim iLast As Long, iFirst As Long
Dim i As Long, n As Integer
Dim j As Integer
vC = Array(1, 3, 4, 5, 6) 'data colums A,C,D,E,F
s = SchMainTasklt.Value
'MsgBox s
sItem = Dic(s)
arr = Split(sItem, ",")
st = Val(arr(0))
ed = Val(arr(1))
iFirst = st + 1
iLast = st + ed
If ed = 0 Then
MsgBox "no data!!"
Exit Sub
End If
For i = iFirst To iLast
n = n + 1
ReDim Preserve vR(1 To 5, 1 To n)
For j = 0 To UBound(vC)
vR(j + 1, n) = vDB(i, vC(j))
Next j
Next i
With ListBox2
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
.Column = vR
End With
End Sub
Result Image
When you click the "KICKOFF" , Show kickoff related data in listbox2.
I am trying to count the number of occurrence for this phrase "SMM:" in each row in column AJ starting from row 2 and then assign the assign the value for each row to column BL starting from row 2.
Sub calculateamlp()
Dim charactercount As Integer
Dim rangeAG As Range
Dim cellCheck As Range
Dim f As Integer
f = 2
Worksheets("pptsr").Activate
Set rangeAG2 = Range("BL2", Range("BL2").End(xlDown))
Set rangeAG = Range("Aj2", Range("Aj2").End(xlDown))
For Each cellCheck In rangeAG
charactercount = Len(cellCheck) - Len(WorksheetFunction.Substitute(cellCheck, ":", ""))
Worksheets("pptsr").Range("BL2" & f).Value = charactercount
f = f + 1
Next cellCheck
End Sub
This function get the count by counting the number of elements in Splitting the String using the with the Substring.
Function getStrOccurenceCount(Text As String, SubString As String)
getStrOccurenceCount = UBound(Split(Text, SubString))
End Function
You could modify your code like this
Worksheets("pptsr").Range("BL2" & f).Value = getStrOccurenceCount(cellCheck.Text, "SMM:")
Here is how you could use the getStrOccurenceCount with arrays to improve your efficiency.
Sub calculateamlp2()
Const SUBSTRING As String = "SMM:"
Dim rangeAG As Range
Dim data As Variant
Dim x As Long
Set rangeAG = Range("AJ2", Range("AJ2").End(xlDown))
data = rangeAG.Value
For x = 1 To UBound(data)
data(x, 1) = getStrOccurenceCount(CStr(data(x, 1)), SUBSTRING)
Next
rangeAG.EntireRow.Columns("BL").Value = data
End Sub
Demo: Sample data 999,999 rows, execution time 0.9375 Seconds:
For exact match you should use "vbBinaryCompare". If you want to match "smm:" with "SMM:" then you should use "vbTextCompare". Try this:
Sub calculateamlp()
Dim count As Long, i As Long, j As Long, rw As Long
Dim ws As Worksheet
Set ws = Worksheets("pptsr")
With ws
rw = .Range("AJ" & .Rows.count).End(xlUp).Row
For i = 2 To rw
For j = 1 To Len(.Cells(i, "AJ"))
If InStr(j, .Cells(i, "AJ"), "SMM:", vbTextCompare) Then
count = count + 1
j = InStr(j, .Cells(i, "AJ"), "SMM:", vbTextCompare)
End If
Next j
.Cells(i, "BL") = count
count = 0
Next
End With
End Sub
Background: I have already used the 'conditional' formatting to highlight the 10 lowest values in each row in light red.
Now, I am trying to compose a code that searches each row for the red marked cells and copies their name from the header row to a new sheet.
What I am aiming for is the following: a code that searches each row for the cells in red and that copies the name (in header) to the same row in another sheet (=result sheet). This should result in a result sheet with 11 columns: first column being the dates and the following 10 columns in that row being the names of the lowest values for that date.
This is the code that I have so far but it does not work:
Sub CopyReds()
Dim i As Long, j As Long
Dim sPrice As Worksheet
Dim sResult As Worksheet
Set sPrice = Sheets("Prices")
Set sResult = Sheets("Result")
i = 2
For j = 2 To 217
Do Until i = 1086
If sPrice.Cells(j, i).Offset(j, 0).Interior.Color = 13551615 Then
sPrice.Cells(j, i).Copy Destination:=sResult.Cells(2, 2).Offset(j, 1)
End If
Loop
Next j
End Sub
Update: screenshot worksheet
Update 2: Screenshot result sample
I think your code should look something like this:
Option Explicit
Sub CopyReds()
Dim sPrice As Worksheet: Set sPrice = Sheets("Prices")
Dim sResult As Worksheet: Set sResult = Sheets("Result")
Const colPriceName As Long = 2 ' The column in which cells can be colored red and contains the names to copy
Const clrCopy As Long = 13551615 ' The color which indicates that the cell should be copied (red)
Const colResult As Long = 2 ' The column where the results should be copied
Const rowResultFirst As Long = 2 ' First row on sResult to use for output
Dim rowResult As Long: rowResult = rowResultFirst
Dim rowPrice As Long: For rowPrice = 2 To sPrice.UsedRange.Rows.Count - sPrice.UsedRange.Row + 1 ' Loop until last row
If DisplayedColor(sPrice.Cells(rowPrice, colPriceName)) = clrCopy Then
sResult.Cells(rowResult, colResult).Value = sPrice.Cells(rowPrice, colPriceName).Value
rowResult = rowResult + 1
End If
Next rowPrice
End Sub
Update: handling conditional formatting
If you use conditional formatting then VBA does not read the actual color displayed but the color which would be shown without Conditional Formatting. So you need a vehicle to determine the displayed color. I wrote this code based on this source but refactored it significantly, e.g. now it did not work in international environment and its readability was poor:
Function DisplayedColor(rngCell As Range, Optional bCellInterior As Boolean = True, Optional bReturnColorIndex As Long = False) As Long
Dim ewbTemp As Workbook: Set ewbTemp = Application.Workbooks.Add() ' Creates a new workbook, so that none of the cells of other workbooks is tampered with (not even temporarily) - this may be overkill, you may centralize this object or use existing cells
DisplayedColor = -1 ' Assume Failure and indicate Error
If 1 < rngCell.Count Then
Debug.Print "Error in DisplayedColor: rngCell contains more than 1 cell"
Exit Function
End If
Dim objTarget As Object: Set objTarget = rngCell
Dim i As Long: For i = 1 To rngCell.FormatConditions.Count
With rngCell.FormatConditions(i)
Dim bFormatConditionActive As Boolean: bFormatConditionActive = False
Dim varValue As Variant: varValue = rngCell.Value
Dim strFormula1 As String: strFormula1 = FormulaFromFormulaLocal(.Formula1, ewbTemp.Worksheets(1).Cells(1, 1))
Dim varEval1 As String: varEval1 = rngCell.Worksheet.Evaluate(strFormula1)
If .Type = xlCellValue Then
Select Case .Operator
Case xlEqual
bFormatConditionActive = varValue = varEval1
Case xlNotEqual
bFormatConditionActive = varValue <> varEval1
Case xlGreater
bFormatConditionActive = varValue > varEval1
Case xlGreaterEqual
bFormatConditionActive = varValue >= varEval1
Case xlLess
bFormatConditionActive = varValue < varEval1
Case xlLessEqual
bFormatConditionActive = varValue <= varEval1
Case xlBetween, xlNotBetween
Dim strFormula2 As String: strFormula2 = FormulaFromFormulaLocal(.Formula2, ewbTemp.Worksheets(1).Cells(1, 1))
Dim varEval2 As String: varEval2 = rngCell.Worksheet.Evaluate(strFormula2)
bFormatConditionActive = varEval1 <= varValue And varValue <= varEval2
If .Operator = xlNotBetween Then
bFormatConditionActive = Not bFormatConditionActive
End If
Case Else
Debug.Print "Error in DisplayedColor: unexpected Operator"
Exit Function
End Select
ElseIf .Type = xlExpression Then
bFormatConditionActive = varEval1
Else
Debug.Print "Error in DisplayedColor: unexpected Type"
Exit Function
End If
If bFormatConditionActive Then
Set objTarget = rngCell.FormatConditions(i)
Exit For
End If
End With
Next i
If bCellInterior Then
If bReturnColorIndex Then
DisplayedColor = objTarget.Interior.ColorIndex
Else
DisplayedColor = objTarget.Interior.Color
End If
Else
If bReturnColorIndex Then
DisplayedColor = objTarget.Font.ColorIndex
Else
DisplayedColor = objTarget.Font.Color
End If
End If
ewbTemp.Close False
End Function
Function FormulaFromFormulaLocal(strFormulaLocal As String, rngDummy As Range) As String
Dim strOldFormula As String: strOldFormula = rngDummy.Formula
rngDummy.FormulaLocal = strFormulaLocal
FormulaFromFormulaLocal = rngDummy.Formula
rngDummy.Formula = strOldFormula
End Function
Please also note the change in the If statement of CopyReds (now it calls the above function).
I think that your algorithm should be redesigned: instead of testing the cells displayed color, check if the value is below a limit. This limit can be calculated with WorksheetFunction.Small, which returns the n-th smallest element.
Sub CopyReds()
Dim sPrice As Worksheet: Set sPrice = Sheets("Prices")
Dim sResult As Worksheet: Set sResult = Sheets("Result")
Const colPriceName As Long = 2 ' The column in which cells can be colored red and contains the names to copy
Const clrCopy As Long = 13551615 ' The color which indicates that the cell should be copied (red)
Const colResult As Long = 2 ' The column where the results should be copied
Const rowResultFirst As Long = 2 ' First row on sResult to use for output
Const lngCount As Long = 10 ' Copy lngCount lowest elements (the actual number may be higher due to ties)
Const colSort As Long = 2 ' The column in which cells contain the values from which the lowest lngCount should be selected
Dim varLimit As Variant: varLimit = Application.WorksheetFunction.Small(sPrice.UsedRange.Cells(2, colSort).Resize(sPrice.UsedRange.Rows.Count - 1, 1), 10)
Dim rowResult As Long: rowResult = rowResultFirst
Dim rowPrice As Long: For rowPrice = 2 To sPrice.UsedRange.Rows.Count - sPrice.UsedRange.Row + 1 ' Loop until last row
If sPrice.Cells(rowPrice, colSort).Value <= varLimit Then
sResult.Cells(rowResult, colResult).Value = sPrice.Cells(rowPrice, colPriceName).Value
rowResult = rowResult + 1
End If
Next rowPrice
End Sub
Based on the screenshots, I revised the code:
Sub CopyReds()
Dim sPrice As Worksheet: Set sPrice = Sheets("Prices")
Dim sResult As Worksheet: Set sResult = Sheets("Result")
Const rowResultFirst As Long = 2 ' First row on sResult to use for output
Const rowPriceFirst As Long = 2 ' First row on sPrice to process
Const lngCount As Long = 10 ' Copy lngCount lowest elements (the actual number may be higher due to ties)
Const colDate As Long = 1 ' The column which contains the dates
Const colValueStart As Long = 2 ' The column where values start
Dim rowResult As Long: rowResult = rowResultFirst
Dim rowPrice As Long: For rowPrice = rowPriceFirst To sPrice.UsedRange.Rows.Count - sPrice.UsedRange.Row + 1 ' Loop until last row
Dim colResult As Long: colResult = 1
sResult.Cells(rowResult, colResult).Value = sPrice.Cells(rowPrice, colDate).Value
colResult = colResult + 1
Dim varLimit As Variant: varLimit = Application.WorksheetFunction.Small(sPrice.Cells(rowPrice, colValueStart).Resize(1, sPrice.UsedRange.Columns.Count - colValueStart + 1), lngCount)
Dim colPrice As Long: For colPrice = colValueStart To sPrice.UsedRange.Columns.Count - colValueStart + 1
If sPrice.Cells(rowPrice, colPrice).Value <= varLimit Then
sResult.Cells(rowResult, colResult).Value = sPrice.Cells(rowResultFirst - 1, colPrice).Value
colResult = colResult + 1
End If
Next colPrice
rowResult = rowResult + 1
Next rowPrice
End Sub
Just to clarify my comment, you need to "advance" either the Cells(j, i) or the Offset(j, 0).
If you decided to use For loops, try to stick with it for both cases:, see code below:
For j = 2 To 217
For i = 2 To 1086
Debug.Print sPrice.Cells(j, i).Interior.Color ' <-- for Debug only
If sPrice.Cells(j, i).Interior.Color = 13551615 Then
sPrice.Cells(j, i).Copy Destination:=sResult.Cells(2, 2).Offset(j, 1)
End If
Next i
Next j
I have an issue which I use a lot of manual time on currently.
I have following simple data:
And I wish to convert all the accounts downwards with the name next to the accounts in another column. Currently I do this by using the 'text to columns' function and then manually copy the names down.. HARD work.. :)
This is an example of my wish scenario..
Hope you are able to help..
Thanks a lot
Kristoffer
The following short macro will take data from Sheet1 and output records in Sheet2:
Sub DataReorganizer()
Dim i As Long, j As Long, N As Long
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 2 To N
v1 = s1.Cells(i, 1)
ary = Split(s1.Cells(i, 2), ";")
For Each a In ary
s2.Cells(j, 1).Value = v1
s2.Cells(j, 2).Value = a
j = j + 1
Next a
Next i
End Sub
Input:
and output:
Try this
Option Explicit
Sub Test()
Dim rng As Excel.Range
Set rng = ThisWorkbook.Worksheets.Item(1).Cells(1, 1).CurrentRegion
Set rng = rng.Offset(1)
Set rng = rng.Resize(rng.Rows.Count - 1)
Dim vPaste
Dim lTotalRows As Long
Dim lPass As Long
For lPass = 0 To 1
Dim rowLoop As Excel.Range
For Each rowLoop In rng.Rows
Dim sName As String
sName = rowLoop.Cells(1, 1)
Dim sAccounts As String
sAccounts = rowLoop.Cells(1, 2)
Dim vSplitAccounts As Variant
vSplitAccounts = VBA.Split(sAccounts, ";")
If lPass = 0 Then
lTotalRows = lTotalRows + UBound(vSplitAccounts) + 1
Else
Dim vLoop As Variant
For Each vLoop In vSplitAccounts
lTotalRows = lTotalRows + 1
vPaste(lTotalRows, 1) = sName
vPaste(lTotalRows, 2) = vLoop
Next vLoop
End If
Next
If lPass = 0 Then
ReDim vPaste(1 To lTotalRows, 1 To 2)
lTotalRows = 0
End If
Next
ThisWorkbook.Worksheets.Item(2).Cells(1, 1).Value = "Name"
ThisWorkbook.Worksheets.Item(2).Cells(1, 2).Value = "Account"
Dim rngPaste As Excel.Range
Set rngPaste = ThisWorkbook.Worksheets.Item(2).Cells(2, 1).Resize(lTotalRows, 2)
rngPaste.Value2 = vPaste
End Sub
I'm trying to write some VBA that will find the matching numbers that appear in both Sheet 1 and Sheet 2, and output them to Sheet 3. My code is below, but is producing no result. What am I doing wrong?
Sub match()
Dim a As Integer
dim i as long, ii as long
a = 2
Dim lastrow As Long
Dim ylastrow As Long
ylastow = Sheets("Sheet2").UsedRange.Rows.Count
lastrow = Sheets("Sheet1").UsedRange.Rows.Count
for i = a to lastrow
for ii = a to ylastrow
if Sheets("Sheet1").Cells(i,1) = Sheets("Sheet2").Cells(ii,2) then
Sheets("Sheet3").range("A100000").xlup
End Sub
Assuming you want the matching cells copied into sheet3 by rows continuously
You are missing next ii and next i and end if also your destination cell in sheet3 is not set right
this should work
Sub match()
Dim a As Integer
Dim i As Long, ii As Long, j As Long
a = 2
j = 2
Dim lastrow As Long
Dim ylastrow As Long
Sheet1rows = Sheets("Sheet1").UsedRange.Rows.Count + 1
sheet2rows = Sheets("Sheet2").UsedRange.Rows.Count + 1
For i = a To Sheet1rows
For ii = a To sheet2rows
If Sheets("Sheet1").Cells(i, 1) = Sheets("Sheet2").Cells(ii, 1) Then
Sheets("Sheet3").Range("A" & j) = Sheets("Sheet1").Cells(i, 1)
j = j + 1
End If
Next ii
Next i
End Sub