I aim to select the rows corresponding to criteria in inputboxes, copy it, and paste it to another worksheet.
The code works but I need to fill all the inputboxes to copy paste the desired rows.
I would like if I do not fill one inputbox, still return all the rows matching the other criteria (example: if just fill the "Issue" InputBox it returns the rows with the matching issue date).
Sub filter()
Dim Bookrunner As String
Dim Bond_Type As Variant
Dim Currency_st As String
Dim Year_Issue As Integer
Bond_Type = InputBox("Choose a Bond Type", "Bond Type")
Currency_st = InputBox("Choose a Currency", "Currency")
Year_Issue = InputBox("Chosse the Year of Issuance", "Issue")
Bookrunner = InputBox("Choose a Bookrunner", "Bookrunner")
Dim copyFrom As Range
Dim i As Long
With Feuil1
For i = 2 To 54
If .Range("B" & i) = Bond_Type And _
.Range("K" & i) = Currency_st And _
.Range("D" & i).Value = Year_Issue And _
(.Range("R" & i) = Bookrunner Or .Range("S" & i) = Bookrunner Or _
.Range("T" & i) = Bookrunner Or .Range("U" & i) = Bookrunner Or _
.Range("V" & i) = Bookrunner Or .Range("w" & i) = Bookrunner) Then
If copyFrom Is Nothing Then
Set copyFrom = .Range("B" & i)
Else
Set copyFrom = Union(.Range("B" & i), copyFrom)
End If
End If
Next
End With
If Not copyFrom Is Nothing Then copyFrom.EntireRow.Copy Destination:=Sheets("Feuil2").Range("A2")
End Sub
Related
I have several columns that I need to concatenante, while the text styling for one column is kept intact and each column is concatenated in a new line (carriage return).
Col A text in bold, Col B text normal, Col C = concatenated col A content in bold + carriage return + col B content.
Using Concatenate formula in combination with CHAR(10) works but obviously the text styling isn't kept. VBA seems to be the way to go but I'm a total newbie at it.
I found the following code that does the concatenation, kees the styling but for the life of me I cant figure how to include a carriage return with vbCrLf in a string.
Sub MergeFormatCell()
Dim xSRg As Range
Dim xDRg As Range
Dim xRgEachRow As Range
Dim xRgEach As Range
Dim xRgVal As String
Dim I As Integer
Dim xRgLen As Integer
Dim xSRgRows As Integer
Dim xAddress As String
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xSRg = Application.InputBox("Select cell columns to concatenate:", "Concatenate in Excel", xAddress, , , , , 8)
If xSRg Is Nothing Then Exit Sub
xSRgRows = xSRg.Rows.Count
Set xDRg = Application.InputBox("Select cells to output the result:", "Concatenate in Excel", , , , , , 8)
If xDRg Is Nothing Then Exit Sub
Set xDRg = xDRg(1)
For I = 1 To xSRgRows
xRgLen = 1
With xDRg.Offset(I - 1)
.Value = vbNullString
.ClearFormats
Set xRgEachRow = xSRg(1).Offset(I - 1).Resize(1, xSRg.Columns.Count)
For Each xRgEach In xRgEachRow
.Value = .Value & Trim(xRgEach.Value) & " "
Next
For Each xRgEach In xRgEachRow
xRgVal = xRgEach.Value
With .Characters(xRgLen, Len(Trim(xRgVal))).Font
.Name = xRgEach.Font.Name
.FontStyle = xRgEach.Font.FontStyle
.Size = xRgEach.Font.Size
.Strikethrough = xRgEach.Font.Strikethrough
.Superscript = xRgEach.Font.Superscript
.Subscript = xRgEach.Font.Subscript
.OutlineFont = xRgEach.Font.OutlineFont
.Shadow = xRgEach.Font.Shadow
.Underline = xRgEach.Font.Underline
.ColorIndex = xRgEach.Font.ColorIndex
End With
xRgLen = xRgLen + Len(Trim(xRgVal)) + 1
Next
End With
Next I
End Sub
The interest of the above code is that it allows the user to specify via an input box the cells range to concatenate and where to output the results.
Anyone can give me a hand and modify it so each new column goes in a new line after concatenation?
If you got a simplier solution I'm all for it as long as it works.
p.s. I'm running Excel 2013 if that matters.
This below code does not copy formatting, but it is concatenate both columns and bold the value appears in column A.
Option Explicit
Sub test()
Dim LastRow As Long, Row As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Row = 1 To LastRow
With .Range("C" & Row)
.Value = ThisWorkbook.Worksheets("Sheet1").Range("A" & Row).Value & vbNewLine & ThisWorkbook.Worksheets("Sheet1").Range("B" & Row).Value
.Characters(1, Len(ThisWorkbook.Worksheets("Sheet1").Range("A" & Row).Value)).Font.FontStyle = "Bold"
End With
Next Row
End With
End Sub
EDITED VERSION:
Option Explicit
Sub test()
Dim LastRow As Long, Row As Long
Dim strA As String, strB As String, strC As String, strD As String, strE As String, strF As String
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Row = 1 To LastRow
strA = .Range("A" & Row).Value
strB = .Range("B" & Row).Value
strC = .Range("C" & Row).Value
strD = .Range("D" & Row).Value
strE = .Range("E" & Row).Value
strF = .Range("F" & Row).Value
With .Range("G" & Row)
.Value = strA & vbNewLine & strB & vbNewLine & strC & vbNewLine & strD & vbNewLine & strE & vbNewLine & strF
.Characters(1, Len(strA)).Font.FontStyle = "Bold"
.Characters((Len(strA) + Len(strB) + 5), Len(strC)).Font.FontStyle = "Bold"
.Characters((Len(strA) + Len(strB) + Len(strC) + Len(strD) + 9), Len(strE)).Font.FontStyle = "Bold"
End With
Next Row
End With
End Sub
I'm trying to setup an update data entry form. How can I transition from integer combo box with only numerical values to a data type using string or long combo box with alphanumeric values?
Private Sub UserForm_Activate()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Employee Details")
Dim i As Integer
Me.UsernameComboBox.Clear
Me.UsernameComboBox.AddItem ""
For i = 11 To sh.Range("B" & Application.Rows.Count).End(xlUp).Row
Me.UsernameComboBox.AddItem sh.Range("B" & i).Value
Next i
End Sub
Private Sub UsernameComboBox_Change()
If Me.UsernameComboBox <> "" Then
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Employee Details")
Dim i As Integer
i = Application.Match(VBA.CLng(Me.UsernameComboBox.Value), sh.Range("B:B"), 0)
Me.NameTextBox = sh.Range("A" & i).Value
Me.EmailTextBox = sh.Range("C" & i).Value
Me.BirthdateTextBox = sh.Range("D" & i).Value
Me.NationalIDTextBox = sh.Range("E" & i).Value
Me.EmpIDTextBox = sh.Range("R" & i).Value
Me.DeptTextBox = sh.Range("V" & i).Value
If sh.Range("Y" & i).Value = "Male" Then Me.MaleOptionButton.Value = True
If sh.Range("Y" & i).Value = "Female" Then Me.FemaleOptionButton.Value = True
Me.StatusComboBox = sh.Range("X" & i).Value
Me.CitizenshipComboBox = sh.Range("Z" & i).Value
Me.EthnicityComboBox = sh.Range("F" & i).Value
End If
End Sub
Welcome to SO. Assuming you do want not to change the numeric values in column B to Text or use another column with formula =Text(B11,"#"), it may be easy to use workaround Find. May try
Dim i As Integer
Dim FndRng As Range, c As Range
'i = Application.Match(Me.UsernameComboBox.Value, Sh.Range("B:B"), 0)
Set FndRng = Sh.Range("B11:B" & Sh.Range("B" & Application.Rows.Count).End(xlUp).Row)
Set c = FndRng.Find(Me.UsernameComboBox.Value, , LookIn:=xlValues)
If Not c Is Nothing Then
i = c.Row
Else
MsgBox "Not found"
Exit Sub
End If
This is a follow on from How do I get all the different unique combinations of 3 columns using VBA in Excel?
It almost what i need, however, my requirements is that it sums the third column which will contain figures instead of yes/no
Sub sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim col As New Collection
Dim Itm
Dim cField As String
Const deLim As String = "#"
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
cField = .Range("A" & i).Value & deLim & _
.Range("B" & i).Value & deLim & _
.Range("C" & i).Value
On Error Resume Next
col.Add cField, CStr(cField)
On Error GoTo 0
Next i
i = 2
.Range("A1:C1").Copy .Range("F1")
.Range("I1").Value = "Count"
For Each Itm In col
.Range("F" & i).Value = Split(Itm, deLim)(0)
.Range("G" & i).Value = Split(Itm, deLim)(1)
.Range("H" & i).Value = Split(Itm, deLim)(2)
For j = 2 To lRow
cField = .Range("A" & j).Value & deLim & _
.Range("B" & j).Value & deLim & _
.Range("C" & j).Value
If Itm = cField Then nCount = nCount + 1
Next
.Range("I" & i).Value = nCount
i = i + 1
nCount = 0
Next Itm
End With
End Sub
This code was originally added by
Siddharth Rout
try this (follows comments)
Option Explicit
Sub Main()
Dim i As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For i = 4 To Range("A" & Rows.Count).End(xlUp).Row '<-- change 4 and "A" to your data actual upleftmost cell row and column
dict(cells(i, 1).Value & "|" & cells(i, 2).Value) = dict(cells(i, 1).Value & "|" & cells(i, 2).Value) + cells(i, 3).Value '<--| change 3 to your actual "column to sum up" index
Next
With Range("G3").Resize(dict.Count) '<-- change "G3" to your actual upleftmost cell to start writing output data from
.Value = Application.Transpose(dict.Keys)
.TextToColumns Destination:=.cells, DataType:=xlDelimited, Other:=True, OtherChar:="|"
.Offset(, 2).Resize(dict.Count).Value = Application.Transpose(dict.Items) '<--| change 2 to your actual column offset where to start writing summed values form
End With
End Sub
Is there a faster way too compare text/data from different columns? It seems to take longer that desired to execute.
Sub StringCom2()
For Each C In Range("M2:M" & Range("M" & Rows.Count).End(xlUp).Row)
For Each L In Range("X2:X" & Range("X" & Rows.Count).End(xlUp).Row)
If C.Cells.Value = "Audio Accessories" And L.Cells.Value = "Headsets" Then
L.Cells.Offset(0, 18).Value = "Headphones"
End If
Next
Next
For Each C In Range("M2:M" & Range("M" & Rows.Count).End(xlUp).Row)
For Each L In Range("X2:X" & Range("X" & Rows.Count).End(xlUp).Row)
If C.Cells.Value = "Headsets & Car Kits" And L.Cells.Value = "Headsets" Then
L.Cells.Offset(0, 18).Value = "Headsets & Car Kits"
End If
Next
Next
End Sub
You could use "Autofilter()" method of "Range" object
like follows (not by my PC so there may be some typos and or range references/offset to adjust...):
Option Explicit
Sub StringCom2()
With Worksheets("Sheet1") '<--| '<-- change "Sheet1" with your actual sheet name
With .Range("M1:X" & .Cells(.Rows.Count, "M").End(xlUp).Row) '<--| reference its range in columns M:X from row 1 to column "M" last non empty cell row
.AutoFilter field:=1, Criteria1:="Headsets" '<--| filter referenced range on its 1st column ("M") with "Headsets"
.AutoFilter field:=12, Criteria1:="Audio Accessories" '<--|filter referenced range again on its 12th column ("X") with "Audio Accessories"
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then .Offset(1, 19).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible) = "Headphones"'<--| write in cells offsetted 19 columns right of the matching ones
.AutoFilter field:=12, Criteria1:="Headsets & Car Kits" '<--|filter referenced range again on its 12th column ("X") with "Headsets & Car Kits"
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then .Offset(1, 19).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible) = "Headsets & Car Kits"'<--| write in cells offsetted 19 columns right of the matching ones
End With
.AutoFilterMode = False '<--| show all rows back
End With
End Sub
Give this a try and let me know if it terminates faster:
Option Explicit
Sub StringCom_SlightlyImproved()
Dim C As Range, L As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
For Each C In ws.Range("M2:M" & ws.Range("M" & ws.Rows.Count).End(xlUp).Row)
For Each L In ws.Range("X2:X" & ws.Range("X" & ws.Rows.Count).End(xlUp).Row)
If C.Value2 = "Headsets" Then
If L.Value2 = "Audio Accessories" Then L.Offset(0, 18).Value2 = "Headphones"
If L.Value2 = "Headsets & Car Kits" Then L.Offset(0, 18).Value2 = "Headsets & Car Kits"
End If
Next L
Next C
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Changes:
declare all variables to avoid Variants which are slower in performance
turn off unnecessary Excel events, calculation, screen-updating for the sub
bring the two loops together to keep the iterations down
code explicitly
Update:
The following solution should be substantially faster as sheet-access has been limited to a bare minimum. Instead, all calculations / comparisons are completed in memory with variables:
Sub StringCom_Improved()
Dim ws As Worksheet
Dim arrResult As Variant
Dim arrHeadset As Variant
Dim arrAccessories As Variant
Dim i As Long, j As Long, maxM As Long, maxX As Long
Set ws = ThisWorkbook.Worksheets(1)
maxM = ws.Range("M" & ws.Rows.Count).End(xlUp).Row
arrHeadset = ws.Range("M2:M" & maxM).Value2
arrResult = ws.Range("AD2:AD" & maxM).Value2 ' column AD is column M with an offset of 18 columns
maxX = ws.Range("X" & ws.Rows.Count).End(xlUp).Row
arrAccessories = ws.Range("X2:X" & maxX).Value2
For i = LBound(arrHeadset) To UBound(arrHeadset)
For j = LBound(arrAccessories) To UBound(arrAccessories)
If arrHeadset(i, 1) = "Headsets" Then
If arrAccessories(j, 1) = "Audio Accessories" Then arrResult(i, 1) = "Headphones"
If arrAccessories(j, 1) = "Headsets & Car Kits" Then arrResult(i, 1) = "Headsets & Car Kits"
End If
Next j
Next i
ws.Range("AD2:AD" & maxM).Value2 = arrResult
End Sub
The faster way is to use Excel formulas
Sub StringCom2()
m = Range("M" & Rows.Count).End(xlUp).Row
x = Range("X" & Rows.Count).End(xlUp).Row
Set r = Range("X2:X" & x).Offset(, 18)
r.Formula = "= If( CountIf( M2:M" & m & " , ""Headsets"" ) , " & _
" If( X2 = ""Audio Accessories"" , ""Headphones"", " & _
" If( X2 = ""Headsets & Car Kits"" , X2 , """" ) , """" ) , """" ) "
r.Value2 = r.Value2 ' optional to replace the formulas with the values
End Sub
I'm new at this, apologies in advance.
This code searches for specific values in a column in one sheet, stores the row reference of the value found then uses it to copy input values into the spreadsheet then copies output values into a summary. It works ... but is there a way of setting "Set" variables into a loop?
Dim i As Long
Dim wb As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim RNG(1 To 8) As Range
Dim MyVal As Variant
'Set value of rows to work down
MyVal = InputBox("To what row to calculate", "Enter a row number", 36)
If MyVal > 52 Then
MsgBox ("You can't enter a number greater than 52")
MyVal = InputBox("To what row to calculate", "Enter a row number", 52)
End If
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("Individual Carry")
Set sht2 = wb.Sheets("Detail")
Set RNG1 = sht2.Range("A:A").Find("V1", LookIn:=xlValues, LookAt:=xlWhole)
Set RNG2 = sht2.Range("A:A").Find("V2", LookIn:=xlValues, LookAt:=xlWhole)
Set RNG3 = sht2.Range("A:A").Find("V3", LookIn:=xlValues, LookAt:=xlWhole)
Set RNG4 = sht2.Range("A:A").Find("V4", LookIn:=xlValues, LookAt:=xlWhole)
Set RNG5 = sht2.Range("A:A").Find("V5", LookIn:=xlValues, LookAt:=xlWhole)
Set RNG6 = sht2.Range("A:A").Find("V6", LookIn:=xlValues, LookAt:=xlWhole)
Set RNG7 = sht2.Range("A:A").Find("V7", LookIn:=xlValues, LookAt:=xlWhole)
Set RNG8 = sht2.Range("A:A").Find("V8", LookIn:=xlValues, LookAt:=xlWhole)
'Set variables equal to Rows of output cells
V1 = RNG1.Row
V2 = RNG2.Row
V3 = RNG3.Row
V4 = RNG4.Row
V5 = RNG5.Row
V6 = RNG6.Row
V7 = RNG7.Row
V8 = RNG8.Row
'Clear result range
sht1.Range("U8:Z52").ClearContents
'Loop through assumptions and copy outputs to result field
For i = 8 To MyVal
'Copy inputs into calculation sheet
sht2.Range("J" & V1) = sht1.Range("D" & i).Value
sht2.Range("E" & V2) = sht1.Range("E" & i).Value
sht2.Range("E" & V2 + 1) = sht1.Range("F" & i).Value
sht2.Range("E" & V2 + 2) = sht1.Range("G" & i).Value
sht2.Range("E" & V2 + 3) = sht1.Range("H" & i).Value
sht2.Range("E" & V2 + 4) = sht1.Range("I" & i).Value
sht2.Range("E" & V2 + 5) = sht1.Range("J" & i).Value
sht2.Range("E" & V2 + 6) = sht1.Range("K" & i).Value
sht2.Range("E" & V2 + 7) = sht1.Range("L" & i).Value
sht2.Range("E" & V2 + 8) = sht1.Range("M" & i).Value
sht2.Range("E" & V2 + 9) = sht1.Range("N" & i).Value
sht2.Range("E" & V2 + 10) = sht1.Range("O" & i).Value
sht2.Range("E" & V2 + 11) = sht1.Range("P" & i).Value
sht2.Range("E" & V2 + 12) = sht1.Range("Q" & i).Value
sht2.Range("E" & V2 + 13) = sht1.Range("R" & i).Value
sht2.Range("E" & V2 + 14) = sht1.Range("S" & i).Value
sht2.Range("E" & V2 + 15) = sht1.Range("T" & i).Value
'Copy result to inputs sheet
sht1.Range("U" & i).Value = sht2.Range("E" & V3) / 1000
sht1.Range("V" & i).Value = sht2.Range("E" & V4) / 1000
sht1.Range("W" & i).Value = sht2.Range("E" & V5) / 1000
sht1.Range("X" & i).Value = sht2.Range("E" & V6) / 1000
sht1.Range("Y" & i).Value = sht2.Range("E" & V7) / 1000
sht1.Range("Z" & i).Value = sht2.Range("E" & V8) / 1000
Next i
MsgBox ("Command Complete")
Concentrating on the part you were asking about:
Dim arrVals, R() As Long, x, wb As Workbook, sht2 As Worksheet
'all the values to be located in ColA...
arrVals = Array("V1", "V2", "V3", "V4", "V5", "V6", "V7", "V8")
Set wb = ThisWorkbook
Set sht2 = wb.Sheets("Detail")
'resize the "rows" array to have the same # of elements as arrVals
ReDim R(1 To UBound(arrVals) + 1) '+1 is because arrVals is zero-based
For x = 1 To UBound(R)
'Note: if there's any possibility of a value not being found, this will error
' at runtime
R(x) = sht2.Range("A:A").Find(arrVals(x - 1), LookIn:=xlValues, LookAt:=xlWhole).Row
Next x
Debug.Print R(3) 'just checking one of the values...
'R(1) is now the same as V1 in you posted code, R(2)=V2, etc
If using an ascending notation starting with 1, also a collection will do, like this:
Dim sht As Worksheet, MyVal As Variant, x As Variant
Dim MyCol As New Collection, i As Long
'Set value of rows to work down
MyVal = 53
While MyVal > 52
MyVal = InputBox("To what row to calculate", "Enter a row number", 36)
If Not IsNumeric(MyVal) Then Exit Sub
If MyVal > 52 Then MsgBox ("You can't enter a number greater than 52")
Wend
With ThisWorkbook.Sheets("Detail")
Set sht = .Parent.Sheets("Individual Carry")
For Each x In Evaluate("""v""&ROW(1:8)")
MyCol.Add .Columns(1).Find(x, , &HEFBD, 1).Row
Next
'Clear result range
sht.[U8:Z52].ClearContents
'Loop through assumptions and copy outputs to result field
For x = 8 To MyVal
'Copy inputs into calculation sheet
.Cells(MyCol(1), 10).Value2 = sht.Cells(x, 4).Value2
.Cells(MyCol(2), 5).Resize(15).Value2 = Application.Transpose(sht.Cells(x, 5).Resize(, 15).Value2)
'Copy result to input sheet
For i = 3 To 8
sht.Cells(x, 18 + i).Value2 = .Cells(MyCol(i), 5).Value2 / 1000
Next
Next
End With
MsgBox "Command Complete"
Because there is no way of testing this without proper data, there may be some errors :P