I'm trying to fill a listview in a userform from a range in Sheet1
This is the code I'm using
Private Sub UserForm_Activate()
'Set some of the properties for the ListView
With Me.ListView1
.HideColumnHeaders = False
.View = lvwReport
End With
'Declare the variables
Dim wksSource As Worksheet
Dim rngData As Range
Dim rngCell As Range
Dim LstItem As ListItem
Dim RowCount As Long
Dim ColCount As Long
Dim i As Long
Dim j As Long
'Set the source worksheet
Set wksSource = Worksheets("Sheet1")
'Set the source range
Set rngData = wksSource.Range("A1").CurrentRegion
'Add the column headers
For Each rngCell In rngData.Rows(1).Cells
Me.ListView1.ColumnHeaders.Add Text:=rngCell.Value, Width:=90
Next rngCell
'Count the number of rows in the source range
RowCount = rngData.Rows.Count
'Count the number of columns in the source range
ColCount = rngData.Columns.Count
'Fill the ListView
For i = 2 To RowCount
Set LstItem = Me.ListView1.ListItems.Add(Text:=rngData(i, 1).Value) '==> Error here
For j = 2 To ColCount
LstItem.ListSubItems.Add Text:=rngData(i, j).Value
Next j
Next i
End Sub
But the problem is that I always get this error
Run-time error '13':
Type mismatch
Any help plz ?
Thank u in advance
Replace:
Set LstItem = Me.ListView1.ListItems.Add(Text:=rngData(i, 1).Value)
with:
Set LstItem = Me.ListView1.ListItems.Add(Text:=rngData(i, 1).Text)
Replace:
Set LstItem = Me.ListView1.ListItems.Add(Text:=rngData(i, 1).Value)
With:
Me.ListView1.ListItems.Add(Text:=rngData(i, 1).Value)
Try removing "Set LstItem = "
Related
I'm trying to compare column A in sheet2 to column A in sheet1 and when there's a match, copy the row from sheet1 to sheet3 with the same order. And if there is a repetition, it should be included too. I also need it to show the mismatching values empty. I did this macro but I can not allow the duplicates to be included.
Sub compareAndCopy()
Dim lastRowE As Long
Dim lastRowF As Long
Dim lastRowM As Long
Dim foundTrue As Boolean
' stop screen from updating to speed things up
Application.ScreenUpdating = False
lastRowE = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Sheet3").Cells(Sheets("Sheet3").Rows.Count, "B").End(xlUp).Row
For i = 1 To lastRowE
foundTrue = False
For j = 1 To lastRowF
If Sheets("Sheet2").Cells(i, 1).Value = Sheets("Sheet1").Cells(j, 1).Value Then
lastRowM = lastRowM + 1
Sheets("Sheet1").Rows(i).Copy Destination:= _
Sheets("Sheet3").Rows(lastRowM)
foundTrue = True
Exit For
End If
Next j
'If Not foundTrue Then
' MsgBox ("didn't find string: " & Sheets("Sheet2").Cells(i, 2).value)
'End If
Next i
' allow screen updating
Application.ScreenUpdating = True
End Sub
Group Data
Loops through probably unique values in column A of Sheet2.
For each cell value, it uses the Find and FindNext methods to find all the matching cells in column A of Sheet1.
Then it writes each of the cell values to a key, and using Union, combines each matching cell to a range object in the corresponding item.
Then it loops through the dictionary and copies the entire rows of each item (range) to Sheet3.
Finally, it clears the newly added values in column A of Sheet3.
The result in Sheet3 is data from Sheet1 grouped by the values in column A of Sheet2.
Option Explicit
Sub CompareAndCopy()
Const eName As String = "Sheet2"
Const eCol As String = "A"
Const efRow As Long = 1 ' don't you have headers?
Const fName As String = "Sheet1"
Const fCol As String = "A"
Const ffRow As Long = 1 ' don't you have headers?
Const mName As String = "Sheet3"
Const mCol As String = "B" ' "A" is empty!
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ews As Worksheet: Set ews = wb.Worksheets(eName)
Dim elRow As Long: elRow = ews.Cells(ews.Rows.Count, eCol).End(xlUp).Row
If elRow < efRow Then Exit Sub ' no data
Dim erg As Range: Set erg = ews.Cells(efRow, eCol).Resize(elRow - efRow + 1)
'Debug.Print erg.Address
Dim fws As Worksheet: Set fws = wb.Worksheets(fName)
Dim flRow As Long: flRow = fws.Cells(fws.Rows.Count, fCol).End(xlUp).Row
If flRow < ffRow Then Exit Sub ' no data
Dim frg As Range:
Set frg = fws.Cells(ffRow, fCol).Resize(flRow - ffRow + 1)
'Debug.Print frg.Address
Dim mws As Worksheet: Set mws = wb.Worksheets(mName)
Dim mifCell As Range
Set mifCell = mws.Cells(mws.Rows.Count, mCol).End(xlUp).Offset(1) _
.EntireRow.Columns("A") ' entire rows
Dim mfCell As Range: Set mfCell = mifCell
'Debug.Print mfCell.Address
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Application.ScreenUpdating = False
Dim frCount As Long: frCount = frg.Rows.Count
Dim eCell As Range
Dim eValue As Variant
Dim fCell As Range
Dim FirstAddress As String
For Each eCell In erg.Cells
eValue = eCell.Value
Set fCell = frg.Find(eValue, frg.Cells(frCount), xlFormulas, xlWhole)
If Not fCell Is Nothing Then
FirstAddress = fCell.Address
Do
If dict.Exists(eValue) Then
Set dict(eValue) = Union(dict(eValue), fCell)
Else
Set dict(eValue) = fCell
End If
Set fCell = frg.FindNext(fCell)
Loop Until fCell.Address = FirstAddress
End If
Next eCell
If dict.Count = 0 Then Exit Sub ' no data¸
Dim rg As Range
Dim Item As Variant
Dim irCount As Long
For Each Item In dict.Items
irCount = Item.Cells.Count
'Debug.Print Item.Address, irCount
Item.EntireRow.Copy mfCell.EntireRow
Set mfCell = mfCell.Offset(irCount)
Next Item
mifCell.Resize(mfCell.Row - mifCell.Row).ClearContents ' or .Clear
Application.ScreenUpdating = True
MsgBox "Data grouped.", vbInformation
End Sub
i just get one names range with this code, what's my fault?
any help, my language is so bad, sorry!
Sub Create_Names()
Worksheets("DATA").Activate
Dim rng As Range
With ActiveSheet
Set rng = Range("J2:J10, J47:S67")
End With
rng.Select
With Selection
'Set rng = Selection
Dim i As Integer
Dim n As Long
Dim new_range As Range
Dim col_num As Integer
Dim first_Row As Long
Dim last_row As Long
For i = 1 To rng.Columns.Count
For n = rng.Rows.Count To 1 Step -1
col_num = rng.Columns(i).Column
first_Row = rng.Rows(1).Row
last_row = rng.Rows(n).Row
If Cells(last_row, col_num).Value <> "" Then
Set new_range = Range(Cells(first_Row, col_num), Cells(last_row, col_num))
new_range.CreateNames Top:=True
Exit For
End If
Next n
Next i
End With
End Sub
i have a big data, and i want to create names range once to make it simple.. help me please..
i change my code and its work like i want..
for each rng in Application.Selection.Areas
'i run the code here
next rng
IS THERE LIMIT FOR CREATENAMES?
I GET ERROR WHEN I PUT
Set rng = Range("J2:J10, J47:S67,V47:BI77,BL1:BL21,CB35:CU64,CB120:FW170,CX20:MM35,CX51:EU61")
My data
my name range
I want to retrieve data in a row with the name and the header.
I really appreciate your help
NAME AUG 1, 2019 AUG 2, 2019 AUG 3, 2019
Zoldyk,Hunter 5 7
Luffy,One 1 2 3
Sub Button1_Click()
Dim rngCopy As Range, rngTemp As Range, rngTarget As Range
Dim intMultiple As Integer, i As Integer, intRow As Integer
Dim objSheet As Worksheet
Set objSheet = Sheets(1)
Dim intLastCellIndexInRow As Integer
intLastCellIndexInRow = ActiveCell.SpecialCells(xlLastCell).Column
Dim strRowValue As String
Dim j As Integer
Set rngCopy = Sheet1.Range("A2", Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp)) 'Set range including names
Set rngTarget = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1, 0) 'Set target range to next available row in Sheet2
`For intRow = rngCopy.Rows.Count To 1 Step -1
Set rngTemp = rngCopy.Cells(intRow)
intMultiple = rngTemp.Offset(0, 1) 'Find how many times to copy the name
For i = 1 To intMultiple
For j = 3 To intLastCellIndexInRow
rngTarget.Value = rngTemp.Value 'Copy name
rngTarget.Next.Value = objSheet.Cells(ActiveCell.Row, j) 'Copy ID
Set rngTarget = rngTarget.Offset(1, 0) 'Move target range to next row
Next
Next
Next
End Sub
Zoldyk,hunter|5|aug 1,2019
Zoldyk,hunter| |aug 2,2019
Zoldyk,hunter|7|aug 3,2019
Luffy,One |1|aug 1,2019
Luffy,One |2|aug 2,2019
Luffy,One |3|aug 3,2019
Notes:
Didn't understand your loop,so I have changed it completely
Try and remove the extra declarations that are left in the code.
You can manipulate it to print on other sheet.
You can also use Pivot for this.
Use the Below code :
Sub Button1_Click()
Dim rngCopy As Range, rngTemp As Range, rngTarget As Range
Dim intMultiple As Integer, i As Integer, intRow As Integer
Dim objSheet As Worksheet
Set objSheet = Sheets(1)
Dim strRowValue As String
Dim j As Integer
Dim cl As Integer
Set rngCopy = Sheet1.Range("A2", Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp)) 'Set range including names
Set rngTarget = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1, 0) 'Set target range to next available row in Sheet2\
cl = Sheet1.Range("A1").End(xlToRight).Column
i = rngTarget.row
For Each cel In rngCopy.Cells
For j = 2 To cl
With Sheet1
.Range("A" & i).Value = cel.Value
.Range("B" & i).Value = .Cells(cel.row, j).Value
.Range("C" & i).Value = .Cells(1, j).Value
i = i + 1
End With
Next
Next
End Sub
Demo:
I have a code to copy the entire row if column B contains a certain text ("ACK-", but now I need to copy the entire row directly above the one with the certain text ("ACK-". Is this even possible? Any help will be appreciated.
Sub HEA_Filter()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
strArray = Array("ack-")
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = Sheets("Real Alarms")
For I = 1 To NoRows
Set rngCells = wsSource.Range("B" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
To reference "the row above", you can use the Range.Offset method:
rngCells.Offset(-1).EntireRow.Copy wsDest.Range("A" & DestNoRows)
' ^^^^^^^^^^^^
However, be aware that this raised a runtime error if the range is at row 1, because row 0 does not exist. You might want to add a check for it, for example:
If rngCells.Row > 1 Then rngCells.Offset(-1).EntireRow.Copy ...
I want to retrieve the data in listview from below path instead of same file. Can you please advise as to what all changes are required in my code.
myFileNameDir = "C:\Users\GShaikh\Desktop\Book16.xlsx"
Workbooks.Open Filename:=myFileNameDir, UpdateLinks:=0
Set ws1 = Worksheets("Students")
'Code for retrieving data from same file.
Dim wksSource As Worksheet
Dim rngData As Range
Dim rngCell As Range
Dim LstItem As ListItem
Dim RowCount As Long
Dim ColCount As Long
Dim i As Long
Dim j As Long
Set wksSource = Worksheets("Sheet1")
Set rngData = wksSource.Range("A1").CurrentRegion
For Each rngCell In rngData.Rows(1).Cells
Me.ListView1.ColumnHeaders.Add Text:=rngCell.Value, Width:=90
Next rngCell
RowCount = rngData.Rows.Count
ColCount = rngData.Columns.Count
For i = 2 To RowCount
Set LstItem = Me.ListView1.ListItems.Add(Text:=rngData(i, 1).Value)
For j = 2 To ColCount
LstItem.ListSubItems.Add Text:=rngData(i, j).Value
Next j
Next i
You add the data to the ListView from the rngData Range, and here is where you set up that Range:
Set rngData = wksSource.Range("A1").CurrentRegion
If you want to use the data from the workbook that you opened, you should modify rngData to refer to that workbook instead:
Set rngData = ws1.Range("A1").CurrentRegion