I am using a Listbox which contains the name of folders. I need to select the names from listbox (one at a time, to maintain the order of selection) and add it to the excel column A1, such that each time adding to the next empty cell of column A. I am very new to vb and need help. Below are the approaches i tried.
Approach 1)
Sub AddRecord_Click()
With Sheet1.ListBox1
For intIndex = 0 To .ListCount - 1
With ActiveSheet
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
End With
If .Selected(intIndex) Then
Sheet1.Cells(LastRow, "A") = Sheet1.ListBox1.Value
NextRow = LastRow + 1
End If
Next
End With
End Sub
Approach 2)
Sub AddRecord_Click()
intRecord = (CInt(Range("A1").End(xlDown).Row) + 1)
Sheet1.Cells(intRecord, "A") = Sheet1.ListBox1.Value
intRecord = intRecord + 1
End Sub
Try this may be helpful to u
Sub ListBox7_Change()
Dim i As Long
With ActiveSheet.ListBoxes("List Box 7")
For i = 1 To .ListCount
If .Selected(i) Then
Range("A" & Rows.count).End(xlUp).offset(1).Value = .List(i)
End If
Next i
End With
End Sub
First you get last used row from the excel sheet and finally increment that last row and insert next column value to the excel.
Dim last as Excel.Range = xlWorkSheet.Cells.SpecialCells
(Excel.XlCellType.xlcellTypeLastCell,Type.Missing)
dim lastUsedRow As Integer = last.Row
lastUsedRow += 1
xlWorksheet.RangeA("A"+ lastUserRow).value = ListBox1.Value
Related
I am working on creating a Userform Listbox that is made of 2 columns. The first column is the name which is pulled from the worksheet, while I am attempting to make the second column a vlookup of the first column. I know there are better routes to use than using a vlookup, but the next steps of this userform will need them (Will be summing the duplicates). So far with my attempts I have either not been able to generate the second column, generate a single number, or have the second column refer to empty space. I would appreciate any help with this. Thank you!
Dim i As Long
Dim j As Long
Dim Temp As Variant
Dim List As New Collection
Dim rnArea As Range, rnCell As Range
Dim vaValues As Variant
Dim LookupName As String
ItemSummaryList.ColumnCount = 2
ItemSummaryList.ColumnWidths = "125;75"
Set rnArea = ActiveSheet.Range(Range("G5"), Range("G3003").End(xlUp))
On Error Resume Next
For Each rnCell In rnArea
List.Add rnCell.Value, CStr(rnCell.Value)
'ItemSummaryList.AddItem CStr(rnCell.Value)
MyLookup = Application.WorksheetFunction.VLookup(rnCell, Sheet1.Range("G5:N3003"), 2, False)
ItemSummaryList.List(rnCell.Value, 1) = MyLookup
Next rnCell
On Error GoTo 0
'Hides Blank Spaces
For Each vaValues In List
If vaValues <> vbNullString Then
ItemSummary.ItemSummaryList.AddItem vaValues
End If
Next
'Sorts List
With ItemSummaryList
For i = 0 To .ListCount - 2
For j = i + 1 To .ListCount - 1
If .List(i) > .List(j) Then
Temp = .List(j)
.List(j) = .List(i)
.List(i) = Temp
End If
Next j
Next i
End With
End Sub
My worksheet contains blank rows which I want to keep.
However it also contains groups of two blank rows and I want to keep one of them but delete/remove the other one.
END RESULT: sheet contains only single blank rows.
First attachment shows before (highlighted where two blank rows) and second attachment shows desired final result (worksheet only contains single blank rows).
What is the VBA code to achieve this please?
Something like:
select all
identify where two blank rows are and delete one of those rows
Thanks in advance!
In an attempt to improve the question and show my efforts with my own VBA code.... this is what I had got starting with a variable counter of 0 and when it gets to 2 it would delete a row, it sort of works as in it finds and deletes the desired row but it appears to run an infinite loop :(
Sub EmptyRows()
Dim x As Integer
Dim row As Integer
NumRows = ActiveSheet.UsedRange.Rows.Count
' Select cell A2.
Range("A2").Select
row = 0
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
If Application.CountA(ActiveCell.EntireRow) = 0 Then
row = row + 1
End If
ActiveCell.Offset(1, 0).Select
If Application.CountA(ActiveCell.EntireRow) = 0 Then
row = row + 1
End If
If row >= 2 Then
MsgBox "2 Rows!"
ActiveCell.EntireRow.Delete
End If
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
row = 0
Next
End Sub
Try the next code, please. It will check if really whole analyzed rows are empty:
Sub deleteSecondBlankRow()
Dim sh As Worksheet, arr, rngDel As Range, lastR As Long, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.Count).End(xlUp).row
arr = sh.Range("A2:A" & lastR).value
For i = 1 To UBound(arr)
If arr(i, 1) = "" Then
If WorksheetFunction.CountA(rows(i + 1)) = 0 Then
If arr(i + 1, 1) = "" Then
If WorksheetFunction.CountA(rows(i + 2)) = 0 Then
If rngDel Is Nothing Then
Set rngDel = sh.Range("A" & i + 2)
Else
Set rngDel = Union(rngDel, sh.Range("A" & i + 2))
End If
End If
End If
End If
End If
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Select
End Sub
The code only selects the rows to be deleted. If you check it and what selected is convenient, you should only replace Select with Delete on the last code line...
In my column A I have cells which consists of formatted dates and general formatting. I want to delete rows which are not dates, and I've made this code, but I have to run it multiple times to get it to delete all the rows which aren't dates.
Code:
Sub del_row_not_date()
Dim rng_A_last As Long
Dim i As Integer
rng_A_last = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
Debug.Print rng_A_last
For i = 1 To rng_A_last Step 1
If IsDate(Sheet1.Cells(i, 1)) = False Then
Sheet1.Cells(i, 1).EntireRow.Delete
End If
Next
End Sub
Thanks in advance!
Since rows will
Based on this LINK I found this:
a tip about deleting rows based on a condition If you start at the top and work down, every time you delete a row your counter will effectively move to the cell two rows below the row you deleted because the row immediately below the deleted row moves up (i.e. it is not tested at all).
This works :)
Sub del_row_not_date()
Dim rng_A_last As Long
Dim i As Integer
rng_A_last = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
Debug.Print rng_A_last
For i = rng_A_last To 1 Step -1
'Debug.Print Cells(i, 1).Value
If IsDate(Sheet1.Cells(i, 1)) = False Then
Sheet1.Cells(i, 1).EntireRow.Delete
End If
Next
End Sub
you could try
Sub del_row_not_date()
With Sheet1
.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants, xlTextValues).EntireRow.Delete
End With
End Sub
what above deletes all column "A" not-numbers cells entire row
if you have cells with numbers that are not dates then use:
Option Explicit
Sub del_row_not_date()
Dim i As Integer
With Sheet1
For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1 '<--| loop backwards not to loose next row index after deleting the current one
If Not IsDate(.Cells(i, 1)) Then .Cells(i, 1).EntireRow.Delete
Next i
End With
End Sub
The code below creates an array of unique values from values in Column A. Each selected array element is used to select a range on the sheet. The range is displayed in a userform Listbox.
I would like help with code that would allow the user to scroll through each array ‘MyarUniqVal’ element via two form buttons Right ‘>>’ and Left ‘<<’. Each time a button is pressed a sequential array item will be selected and a new range will populate the Listbox.
Any help would be greatly appreciated.
Thanks,
Please see the code below:
Sub testRange3()
Dim lastrow, i, j As Long
Dim c As Range, rng As Range
Dim MyArUniqVal() As Variant
ReDim MyArUniqVal(0)
'With ActiveSheet
With ThisWorkbook.Worksheets("Temp")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
If .Cells(i, 1).Value <> .Cells(i + 1, 1).Value Then
MyArUniqVal(UBound(MyArUniqVal)) = .Cells(i, 1).Value
ReDim Preserve MyArUniqVal(UBound(MyArUniqVal) + 1)
End If
Next
ReDim Preserve MyArUniqVal(UBound(MyArUniqVal) - 1)
End With
For j = LBound(MyArUniqVal) To UBound(MyArUniqVal)
'Prints out each array to Immediate Window
Debug.Print j
'Prints out unique values from Column A stored in array to Immediate Window
Debug.Print MyArUniqVal(j)
Next
With ThisWorkbook.Worksheets("Temp")
'changed to ActiveSheet
'With ActiveSheet
For Each c In .Range("A1:A" & lastrow)
For j = LBound(MyArUniqVal) To UBound(MyArUniqVal)
If UCase(c.Text) = j Then
'If UCase(c.Text) = "B" Then
If rng Is Nothing Then
Set rng = .Range("B" & c.Row).Resize(, 2)
Debug.Print rng
Else
Set rng = Union(rng, .Range("B" & c.Row).Resize(, 2))
Exit For
Debug.Print rng
End If
End If
Next
Next c
End With
If Not rng Is Nothing Then rng.Select
End Sub
See the following code to get you heading the the right direction. I took the approach of adding another listbox that displayed the available prefixes to help the user see what was available and then searching the data column for entries containing the selected prefix.
Hopefully you will be able to adapt the name of the variables and objects to whatever you are currently using. Let me know if anything needs clarification. Best of luck with your project.
My sample form code:
Private Sub cmdBack_Click()
code_frmMain.IncrementValue (0)
End Sub
Private Sub cmdNext_Click()
code_frmMain.IncrementValue (1)
End Sub
Private Sub lstPrefixes_Change()
code_frmMain.DisplayNext
End Sub
Private Sub UserForm_Initialize()
code_frmMain.testRange3
End Sub
My sample program code:
' This subroutine will search column B for the selected value
Sub DisplayNext()
Dim searchTerm As String
Dim lastRow As Long
Dim i As Integer
' clear frmMain.lstResults
frmMain.lstResults.Clear
For i = 0 To frmMain.lstPrefixes.ListCount - 1
If frmMain.lstPrefixes.Selected(i) = True Then
searchTerm = frmMain.lstPrefixes.List(i)
Exit For ' exits once selected item is found
End If
Next i
'Debug.Print searchTerm
With Sheets("Temp")
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
For i = 1 To lastRow
If InStr(Cells(i, 2).Value, searchTerm) Then
frmMain.lstResults.AddItem (Cells(i, 2).Value)
End If
Next i
End Sub
' increments value. input direction: 0 is down and 1 is up
Sub IncrementValue(direction As Integer)
Dim currentIndex As Integer
currentIndex = -1
For i = 0 To frmMain.lstPrefixes.ListCount - 1
If frmMain.lstPrefixes.Selected(i) = True Then
currentIndex = frmMain.lstPrefixes.ListIndex
Exit For ' exits once selected item is found
End If
Next i
' defaults to first item if none selected
If currentIndex = -1 Then
frmMain.lstPrefixes.Selected(0) = True
currentIndex = 0
End If
If direction = 0 Then
' prevents listIndex from being invalid
If currentIndex = 0 Then
frmMain.lstPrefixes.Selected(frmMain.lstPrefixes.ListCount - 1) = True
Else
frmMain.lstPrefixes.Selected(currentIndex - 1) = True
End If
Else
If currentIndex = frmMain.lstPrefixes.ListCount - 1 Then
frmMain.lstPrefixes.Selected(0) = True
Else
frmMain.lstPrefixes.Selected(currentIndex + 1) = True
End If
End If
End Sub
Note that I also added this to the bottom of your testRange3() to use that data that you had already gathered:
For i = 0 To UBound(MyArUniqVal)
frmMain.lstPrefixes.AddItem (MyArUniqVal(i))
Next i
Sample Data:
Running on user form:
I am trying to get Excel data, which was mapped using a grid/matrix mapping into a de-normalized for so that i can enter the data into a database.
How do you copy data in a grid from one excel sheet to the other as follow illustrated below.
I was trying something like this... but as you can see, i am far off!
Sub NormaliseList(mySelection As Range)
Dim cell As Range
Dim i As Long
i = 1
For Each cell In mySelection
If cell <> "" Then
Sheets(2).Range("A" & i).Value = cell(cell.Row, 1).Value
Sheets(2).Range("B" & i).Value = cell.Value
Sheets(2).Range("C" & i).Value = cell(1, cell.Column).Value
i = i + 1
Next cell
End Sub
For Reference. I Updated my code..
Simply add the code, assign macro shortcut to the function
Select the range that contains the intersection data (not the row and column data)
Run macro (Beware, sheet 2 will have data added in normalised form)
If there are multiple headings that are needed i figured i would consolidate into one column then perform a "text to columns" after processing.
Sub NormaliseList()
' to run - assign macro shortcut to sub - Select Intersection data (not row and column headings and run)
Dim Rowname, ColumnName, IntValue As String
Dim x, cntr As Integer
Dim test As Boolean
cntr = 0
For x = 1 To Selection.Count
If Selection(x).Value <> "" Then
cntr = cntr + 1
Rowname = ActiveSheet.Cells(Selection.Cells(x).Row, Selection.Column - 1)
ColumnName = ActiveSheet.Cells(Selection.Row - 1, Selection.Cells(x).Column)
IntValue = Selection(x).Value
test = addrecord(Rowname, ColumnName, IntValue, cntr)
End If
Next x
End Sub
Function addrecord(vA, vB, vC As String, rec As Integer) As Boolean
'Make sure that you have a worksheet called "Sheet2"
Sheets("Sheet2").Cells(rec, 1) = vA
Sheets("Sheet2").Cells(rec, 2) = vB
Sheets("Sheet2").Cells(rec, 3) = vC
End Function
I've got two posts, with usable code and downloadable workbook, on doing this in Excel/VBA on my blog:
http://yoursumbuddy.com/data-normalizer
http://yoursumbuddy.com/data-normalizer-the-sql/
Here's the code:
'Arguments
'List: The range to be normalized.
'RepeatingColsCount: The number of columns, starting with the leftmost,
' whose headings remain the same.
'NormalizedColHeader: The column header for the rolled-up category.
'DataColHeader: The column header for the normalized data.
'NewWorkbook: Put the sheet with the data in a new workbook?
'
'NOTE: The data must be in a contiguous range and the
'rows that will be repeated must be to the left,
'with the rows to be normalized to the right.
Sub NormalizeList(List As Excel.Range, RepeatingColsCount As Long, _
NormalizedColHeader As String, DataColHeader As String, _
Optional NewWorkbook As Boolean = False)
Dim FirstNormalizingCol As Long, NormalizingColsCount As Long
Dim ColsToRepeat As Excel.Range, ColsToNormalize As Excel.Range
Dim NormalizedRowsCount As Long
Dim RepeatingList() As String
Dim NormalizedList() As Variant
Dim ListIndex As Long, i As Long, j As Long
Dim wbSource As Excel.Workbook, wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet
With List
'If the normalized list won't fit, you must quit.
If .Rows.Count * (.Columns.Count - RepeatingColsCount) > .Parent.Rows.Count Then
MsgBox "The normalized list will be too many rows.", _
vbExclamation + vbOKOnly, "Sorry"
Exit Sub
End If
'You have the range to be normalized and the count of leftmost rows to be repeated.
'This section uses those arguments to set the two ranges to parse
'and the two corresponding arrays to fill
FirstNormalizingCol = RepeatingColsCount + 1
NormalizingColsCount = .Columns.Count - RepeatingColsCount
Set ColsToRepeat = .Cells(1).Resize(.Rows.Count, RepeatingColsCount)
Set ColsToNormalize = .Cells(1, FirstNormalizingCol).Resize(.Rows.Count, NormalizingColsCount)
NormalizedRowsCount = ColsToNormalize.Columns.Count * .Rows.Count
ReDim RepeatingList(1 To NormalizedRowsCount, 1 To RepeatingColsCount)
ReDim NormalizedList(1 To NormalizedRowsCount, 1 To 2)
End With
'Fill in every i elements of the repeating array with the repeating row labels.
For i = 1 To NormalizedRowsCount Step NormalizingColsCount
ListIndex = ListIndex + 1
For j = 1 To RepeatingColsCount
RepeatingList(i, j) = List.Cells(ListIndex, j).Value2
Next j
Next i
'We stepped over most rows above, so fill in other repeating array elements.
For i = 1 To NormalizedRowsCount
For j = 1 To RepeatingColsCount
If RepeatingList(i, j) = "" Then
RepeatingList(i, j) = RepeatingList(i - 1, j)
End If
Next j
Next i
'Fill in each element of the first dimension of the normalizing array
'with the former column header (which is now another row label) and the data.
With ColsToNormalize
For i = 1 To .Rows.Count
For j = 1 To .Columns.Count
NormalizedList(((i - 1) * NormalizingColsCount) + j, 1) = .Cells(1, j)
NormalizedList(((i - 1) * NormalizingColsCount) + j, 2) = .Cells(i, j)
Next j
Next i
End With
'Put the normal data in the same workbook, or a new one.
If NewWorkbook Then
Set wbTarget = Workbooks.Add
Set wsTarget = wbTarget.Worksheets(1)
Else
Set wbSource = List.Parent.Parent
With wbSource.Worksheets
Set wsTarget = .Add(after:=.Item(.Count))
End With
End If
With wsTarget
'Put the data from the two arrays in the new worksheet.
.Range("A1").Resize(NormalizedRowsCount, RepeatingColsCount) = RepeatingList
.Cells(1, FirstNormalizingCol).Resize(NormalizedRowsCount, 2) = NormalizedList
'At this point there will be repeated header rows, so delete all but one.
.Range("1:" & NormalizingColsCount - 1).EntireRow.Delete
'Add the headers for the new label column and the data column.
.Cells(1, FirstNormalizingCol).Value = NormalizedColHeader
.Cells(1, FirstNormalizingCol + 1).Value = DataColHeader
End With
End Sub
You’d call it like this:
Sub TestIt()
NormalizeList ActiveSheet.UsedRange, 1, "Name", "Count", False
End Sub