I'm trying to get all my filtered data in one range variable but it doesn't work.
When the visible datas are continuous (rows 25 to 200), i've no problem but when the visible datas are discontinuous (rows 25 to 27, then 43 to 47, then 60 to 92) it only get the first range (rows 25 to 27)
Here is my code :
datas = dataSheet.Range("A2:L" & dataSheet.
[A65000].End(xlUp).Row).SpecialCells(xlCellTypeVisible).Value
Do you have any tip ?
Thank you for your answer.
Louis
It sounds like you're trying to populate an array variable named datas, which is successful if your range is continuous, but only gets the first section when discontinuous. And what you're looking for is to populate the array with all of the data from the discontinuous range.
That is possible, and there are two approaches. The first is to copy the discontinuous range and paste it into a temp worksheet. The pasted range will be continuous and then you can load it into the array normally as shown in your original code. The second is to populate the array directly, but you'll have to loop through each visible cell to do this.
Method 1 (use temp worksheet):
Sub tgrTempWS()
Dim dataSheet As Worksheet
Dim tempSheet As Worksheet
Dim rData As Range
Dim datas As Variant
Set dataSheet = ActiveWorkbook.Sheets("Sheet1")
On Error Resume Next
Set rData = dataSheet.Range("A2:L" & dataSheet.[A65000].End(xlUp).Row).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rData Is Nothing Then Exit Sub 'No data
Set tempSheet = dataSheet.Parent.Sheets.Add
rData.Copy tempSheet.Range("A1")
datas = tempSheet.Range("A1").CurrentRegion.Value
Application.DisplayAlerts = False
tempSheet.Delete
Application.DisplayAlerts = True
'do stuff with your datas array variable here
End Sub
Method 2 (loop through visible cells):
Sub tgrLoop()
Dim dataSheet As Worksheet
Dim rData As Range
Dim rCell As Range
Dim datas As Variant
Dim lRow As Long, lCol As Long
Dim i As Long, j As Long
Set dataSheet = ActiveWorkbook.Sheets("Sheet1")
On Error Resume Next
Set rData = dataSheet.Range("A2:L" & dataSheet.[A65000].End(xlUp).Row).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rData Is Nothing Then Exit Sub 'No data
ReDim datas(1 To Intersect(rData, rData.Areas(1).Resize(, 1).EntireColumn).Cells.Count, 1 To rData.Columns.Count)
For Each rCell In rData.Cells
If lRow = 0 Then
lRow = rCell.Row
i = 1
ElseIf rCell.Row > lRow Then
i = i + 1
lRow = rCell.Row
End If
If lCol = 0 Or rCell.Column < lCol Then
lCol = rCell.Column
j = 1
ElseIf rCell.Column > lCol Then
j = j + 1
lCol = rCell.Column
End If
datas(i, j) = rCell.Value
Next rCell
'do stuff with your datas array variable here
End Sub
From MSDN about Range Object : "Represents a cell, a row, a column, a selection of cells containing one or more contiguous blocks of cells, or a 3-D range."
That's why you only get the first range. Have a look at this page to refer to multiple ranges.
Related
I am trying to delete rows where the same value occurs in both columns C and D on the same row
I am comparing between column C(BOS address 1) and D (Empower address 1)so if they have the same string remove the whole row. The code is below it executes normally but give Object 424 error after it runs.
Sub test()
Dim try As String
Dim lastrow As Long
Dim x As Variant
Dim row_count As Long
Dim lastrow_str As String
Dim lastrow_rng As String
With empower_report
' Get count of records to search through (list that will be deleted)'
lastrow_str = getColStr("Empower Address 1")
lastrow = Cells(Rows.Count, lastrow_str).End(xlUp).Row
lastrow_rng = getColRange("BOS Address 1")
' Loop through the "master" list'
For Each x In Range(lastrow_rng)
' Loop through all records in the second list.
For row_count = lastrow To 1 Step -1
' Do comparison of next record'
If x.Value = Cells(row_count, 4).Value Then
' If match is true then delete row.
Cells(row_count, 4).EntireRow.Delete
End If
Next row_count
Next
End With
End Sub
The error message ( 424 object required) because of this line. once I press end the code will run.
If x.Value = Cells(row_count, 4).Value Then
Example : input: Column C D
denver denver
denver boston
Output: Column C D
denver boston
I don't have a lot of VBA experience yet. Thank you
since you are trying to delete rows where the same value occurs in both columns C and D on the same row, you only need one loop.
Sub Demo()
Dim FirstDataColumn As Range
Dim SecondDataColumn As Range
Dim i As Long
With empower_report
' get reference to column data by any means you choose
Set FirstDataColumn = .Range( ... )
Set SecondDataColumn = .Range( ... )
If FirstDataColumn.Row <> SecondDataColumn.Row Then
' ranges are not aligned
Exit Sub
End If
If FirstDataColumn.Rows.Count <> SecondDataColumn.Rows.Count Then
' ranges are not the same size
Exit Sub
End If
' Loop the array
For i = FirstDataColumn.Rows.Count To 1 Step -1
' Detect if items on same row are equal
If FirstDataColumn.Cells(i, 1) = SecondDataColumn.Cells(i, 1) Then
' Delete row
FirstDataColumn.Rows(i).EntireRow.Delete
End If
Next
End With
End Sub
Note that this will be slower than it can be because:
Loop ranges is slow
Deleting rows one at a time is slow
If your data sets are small enough this may not be noticable.
On the other hand, if it's too slow for you, then you could
Move the data to a variant array and loop that
Collect a reference to rows to be deleted as you loop, then delete all rows in one go at the end
Remove Duplicates (Loop Column Range)
This is kind of a range study i.e. it surely can be done to be more elegant and more efficient e.g. if you could determine the whole range first, you could use RemoveDuplicates when possible data to the left and/or to the right would not be affected.
Option Explicit
Sub RemoveDupesLoop()
Const Title1 As String = "Empower Address 1"
Const Title2 As String = "BOS Address 1"
Const tRow As Long = 1 ' Title (Header) Row
Dim rg1 As Range
Dim Col2 As Long
With empower_report
Dim cIndex As Variant
cIndex = Application.Match(Title1, .Rows(tRow), 0)
If IsError(cIndex) Then Exit Sub
Dim Col1 As Long: Col1 = cIndex
cIndex = Application.Match(Title2, .Rows(tRow), 0)
If IsError(cIndex) Then Exit Sub
Col2 = cIndex
Dim lRow1 As Long: lRow1 = .Cells(.Rows.Count, Col1).End(xlUp).Row
If lRow1 <= tRow Then Exit Sub
Dim lRow2 As Long: lRow2 = .Cells(.Rows.Count, Col2).End(xlUp).Row
If lRow2 <= tRow Then Exit Sub
Dim lRow As Long
If lRow1 < lRow2 Then
lRow = lRow1
Else
lRow = lRow2
End If
Set rg1 = .Range(.Cells(tRow + 1, Col1), .Cells(lRow, Col1))
End With
Dim drg As Range
Dim cCell As Range
For Each cCell In rg1.Cells
If cCell.Value = cCell.EntireRow.Cells(Col2).Value Then
If drg Is Nothing Then
Set drg = cCell
Else
Set drg = Union(drg, cCell)
End If
End If
Next cCell
If Not drg Is Nothing Then
drg.EntireRow.Delete
End If
End Sub
My ultimate goal is to read a range from one workbook and input it into specific cells in another workbook. The source Workbook has a range of autofiltered data in columns A-D. The destination workbook has 8 fields that need to be filled and they will always be the same. For instance, The source workbook will have the first field of the Array MyArray(x) go into the field B2 on the destination workbook. Then MyArray(x) will have x=2 which will populate D2 in the destination workbook from the next visible row in column B. So, it would look like this:
Source workbook
A
B
C
D
1
User Name
AccountNo
Last3
Software to Load
3
User 2
10161_4002
MM1
License E3
4
User 3
10202_2179
118
6
User 5
10141_9863
AA5
License-E3,Reflection
7
User 6
10167_3006
B35
RSI,Java
9
User 8
10176_3393
W45
Office365,Java
And the destination workbook would look like this:
A
B
C
D
1
2
Name:
Account Number:
3
ID:
Software:
4
5
Name:
Account Number:
6
ID:
Software:
So, after running to sub/function, I would have:
[D]=Destination [S]=Source
[D]B2=[S]A3
[D]D2=[S]B3
[D]B3=[S]C3
[D]D3=[S]D3
[D]B5=[S]A4
[D]D5=[S]B4
[D]B6=[S]C4
[D]D6=[S]D4
And so on with 2 rows from the source getting put into the 8 fields of the destination workbook. I have some very basic code at this point but I know this is pretty convoluted. Here is what I've come up with so far which just loops through all of the visible rows and prints out the lines from the range from A2 through the last cell in D with data in it to the immediate window. I've removed it from my main project and just put it all in 2 new workbooks to simplify everything. Ultimately, I'm going to print each page when the destination gets all 8 fields updated and move on to the next page. My code so far:
Sub AddToPrintoutAndPrint()
Dim rng As Range, lastRow As Long
Dim myArray() As Variant, myString() As String
Dim cell As Range, x As Long, y As Long
Dim ws As Worksheet: Set ws = Sheet1 ' Sheet1
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set rng = Range("A2:D" & lastRow)
For Each cell In rng.SpecialCells(xlCellTypeVisible)
ReDim Preserve myArray(x)
myArray(x) = cell.Value
x = x + 1
Next cell
For x = LBound(myArray) To UBound(myArray)
Debug.Print Trim$(myArray(x))
Next x
Set ws = Nothing
End Sub
Thanks for any suggestions
Edit: New block of code to support printing multiple lines
Sub RunIt()
Dim rng As Range
Dim lastRow As Long
Dim ws As Worksheet
Dim coll As Collection
Dim wsDest As Worksheet
Dim rowCounter As Integer
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set wsDest = Sheets("Sheet2")
Set rng = Range("A2:A" & lastRow)
Set coll = GetUserInfo(rng.SpecialCells(xlCellTypeVisible))
'This is used to keep a running total of how many rows
'were populated. Since the entries are three rows apart
'we can use the offset function in the loop to choose
'the correct entry. This is also flexible enough
'such that if you ever wanted three or more entries
'per sheet, it will work.
rowCounter = 0
For Each itm In coll
wsDest.Range("B2").Offset(rowCounter * 3).Value = itm(0)
wsDest.Range("D2").Offset(rowCounter * 3).Value = itm(1)
wsDest.Range("B3").Offset(rowCounter * 3).Value = itm(2)
wsDest.Range("D3").Offset(rowCounter * 3).Value = itm(3)
'Increment rowcouter, looping around if you surpass
'two (or any future max number of items)
rowCounter = (rowCounter + 1) Mod 2
'If rowCounter has reset to 0, that means its time to
'print or whatever yuo need to do. Do it below
Debug.Print wsDest.Range("B2").Value
Debug.Print wsDest.Range("B5").Value
Next itm
'Here we check if rowcounter does not equal 0. This indicates
'that the loop ended with an odd number of elements, and should be
'printed out to flush that "buffer"
If rowCounter <> 0 Then
'Do final printout
Debug.Print wsDest.Range("B2").Value
Debug.Print wsDest.Range("B5").Value
End If
End Sub
Function GetUserInfo(rng As Range) As Collection
Dim c As Collection
Dim cel As Range
Dim a(0 To 3)
Set c = New Collection
For Each cel In rng
a(0) = cel.Value
a(1) = cel.Offset(, 1).Value
a(2) = cel.Offset(, 2).Value
a(3) = cel.Offset(, 3).Value
c.Add a
Next cel
'Return the collection
Set GetUserInfo = c
End Function
I'd manage it a bit differently. First, I don't think it's wise to ReDim an array in a loop. I'm not sure how efficiently VBA manages resizing arrays, but it can be an expensive process.
I'd store the relevant values from each row into a collection. The items in the collection will be an array with the relevant fields. This collection can then be looped over, with the data being dropped into the relevant fields (and then printed, or whatever needs to be done).
Let me know if this gets you started.
Sub RunIt()
Dim rng As Range
Dim lastRow As Long
Dim ws As Worksheet
Dim coll As Collection
Dim wsDest As Worksheet
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set wsDest = Sheets("Sheet2")
Set rng = Range("A2:A" & lastRow)
Set coll = GetUserInfo(rng)
For Each itm In coll
wsDest.Range("B2").Value = itm(0)
wsDest.Range("D2").Value = itm(1)
wsDest.Range("B3").Value = itm(2)
wsDest.Range("D3").Value = itm(3)
'Maybe do your print routine here, and then reload
Next itm
End Sub
Function GetUserInfo(rng As Range) As Collection
Dim c As Collection
Dim cel As Range
Dim a(0 To 3)
Set c = New Collection
For Each cel In rng
a(0) = cel.Value
a(1) = cel.Offset(, 1).Value
a(2) = cel.Offset(, 2).Value
a(3) = cel.Offset(, 3).Value
c.Add a
Next cel
'Return the collection
Set GetUserInfo = c
End Function
From this data:
I want to produce output like this:
Header is already made, but rest using a formula or vba.
Maybe get a position of cell where value > 0 and offset it or use xlUp/xlLef?
But then what if there are more data to left of fruits and above the dates?
Something like this; manually select table and then run macro ... it will prompt for destination and write it out the list. Ignore's table cells that are blank.
Sub TableToList()
Dim rngSelection As Range
Dim rngDestination As Range
Dim lngRow As Long
Dim lngColumn As Long
Dim lngCounter As Long
' Ensure that the selection is at least 2 rows and 2 columns
Set rngSelection = Application.Selection
If rngSelection.Rows.Count < 2 Or rngSelection.Columns.Count < 2 Then
MsgBox "Selected data must have a minimum of two rows and two columns.", vbInformation
End
End If
' Ask the user to select the cell for where the list is to be written
Set rngDestination = Application.InputBox(prompt:="Select a destination cell:", Type:=8)
' Loop through the table and write out the list.
lngCounter = 0
For lngRow = 2 To rngSelection.Rows.Count
For lngColumn = 2 To rngSelection.Columns.Count
If ActiveCell.Cells(lngRow, lngColumn) <> "" Then
rngDestination.Offset(lngCounter, 0) = ActiveCell.Cells(lngRow, 1)
rngDestination.Offset(lngCounter, 1) = ActiveCell.Cells(1, lngColumn)
rngDestination.Offset(lngCounter, 2) = ActiveCell.Cells(lngRow, lngColumn)
lngCounter = lngCounter + 1
End If
Next
Next
End Sub
An over-simplified description of my problem is illustrated in the figures below. I want to transform sparse data from a column in the Page1 worksheet to dense and then load it in a dense range in the Page2 worksheet.
My solution so far is that in the following code snippet. I would like to know if there is a more efficient alternative to achieve this goal, namely without a for loop or at least without the j variable.
Sub CopyFromMultipleRanges()
With Worksheets("Page1")
.Range("A1:A5").Value = 1
.Range("A8:A10").Value = 2
Dim c_cell As Range
Dim j As Long
j = 1
For Each c_cell In .Range("A1:A5,A8:A10")
Worksheets("Page2").Range("A" & j).Value = c_cell.Value
j = j + 1
Next
End With
Worksheets("Page2").Activate
End Sub
Initial column where data is sparse.
Final dense data column.
You can do this if you want to remove the blanks on the same sheet. If not just copy the data to a new sheet and then run this on that range
Sub Delete_Blank_Rows()
On Error Resume Next
Range("A1:A10").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Here's how I would do it:
'create a collection to store the data
Dim bin As New Collection
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim size As Long
Dim i As Long
Dim v As Variant
'set worksheet references
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Page1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Page2")
With ws1
size = .UsedRange.Rows.Count
'loop through the range to pick up the data from non-empty cells
For i = 1 To size
'if the cell is not empty, then add the value to the collection
If Not IsEmpty(.Cells(i, 1).Value) Then
bin.Add .Cells(i, 1).Value
End If
Next
'loop through the bin contents
i = 1
For Each v In bin
ws2.Cells(i, 1).Value = v
i = i + 1
Next
End With
Hope it helps!
Update:
I tested this code and it works:
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Excel.Application.ThisWorkbook.Worksheets(1)
Set ws2 = Excel.Application.ThisWorkbook.Worksheets(2)
ws1.Range("A:A").SpecialCells(xlCellTypeConstants).Copy ws2.Range("A:A")
End Sub
you can read more about Range.SpecialCells here. learn something new everyday!
This assumes that you are considering the all rows with the lower and upper row limits of the ranges given ie. that "A1:A5" and "A8:A10" is indeed "A1:A10".
Option Explicit
Public Sub CopyFromMultipleRanges()
Dim rng As Range: Set rng = ThisWorkbook.Worksheets("Page1").Range("A1:A10")
Application.ScreenUpdating = False
If Application.WorksheetFunction.CountBlank(rng) = rng.Count Then Exit Sub
With rng
.AutoFilter
.AutoFilter 1, "<>"
.SpecialCells(xlCellTypeVisible).Copy Worksheets("Page2").Range("A1")
.AutoFilter
Application.ScreenUpdating = True
End With
End Sub
This is my first attempt at VBA, so I apologize for my ignorance. The situation is as follows: I have a spreadsheet that consists of 4 columns and 629 rows. When I am trying to do is iterate through the 4 cells in each row and check for a blank cell. If there is a row that contains a blank cell, I want to cut it from Sheet1 and paste it into the first available row in Sheet2.
(Ideally the number of columns AND the number of rows is dynamic based on each spreadsheet, but I have no idea how to iterate through rows and columns dynamically)
Sub Macro1()
'
' Macro1 Macro
' Move lines containing empty cells to sheet 2
'
' Keyboard Shortcut: Ctrl+r
'
Dim Continue As Boolean
Dim FirstRow As Long
Dim CurrentRow As Long
Dim LastRow As Long
Dim EmptySheetCount As Long
Dim Counter As Integer
'Initialize Variables
LContinue = True
FirstRow = 2
CurrentRow = FirstRow
LastRow = 629
EmptySheetCount = 1
'Sheets(Sheet1).Select
'Iterate through cells in each row until an empty one is found
While (CurrentRow <= LastRow)
For Counter = 1 To 4
If Sheet1.Cells(CurrentRow, Counter).Value = "" Then
Sheet1.Cells(CurrentRow).EntireRow.Cut Sheet2.Cells(EmptySheetCount, "A")
EmptySheetCount = EmptySheetCount + 1
Counter = 1
CurrentRow = CurrentRow + 1
GoTo BREAK
Else
Counter = Counter + 1
End If
Counter = 1
BREAK:
Next
Wend
End Sub
When I run it, I typically get an error around the Sheet1.Cells(CurrentRow, Counter).Value = "" area, so I know I'm referencing sheets incorrectly. I've tried Sheets(Sheet1), Worksheets("Sheet1") and nothing seems to be working. When I do change to Worksheets("Sheet1"), however, it runs and just freezes Excel.
I know I'm doing multiple things wrong, I just know way too little to know what.
Thanks a lot in advance. And sorry for the crap formatting.
There are a few things wrong with your code so rather than go through them individually here is a basic looping version that does what you're after.
Sub moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Dim lastColumn As Integer
Dim lastRow As Integer
Dim destinationRow As Integer
Set wksData = Worksheets("Sheet1")
Set wksDestination = Worksheets("Sheet2")
destinationRow = 1
lastColumn = wksData.Range("XFD1").End(xlToLeft).Column
lastRow = wksData.Range("A1048576").End(xlUp).Row
For i = lastRow To 1 Step -1 'go 'up' the worksheet to handle 'deletes'
For j = 1 To lastColumn
If wksData.Cells(i, j).Value = "" Then 'check for a blank cell in the current row
'if there is a blank, cut the row
wksData.Activate
wksData.Range(Cells(i, 1), Cells(i, lastColumn)).Cut
wksDestination.Activate
wksDestination.Range(Cells(destinationRow, 1), Cells(destinationRow, lastColumn)).Select
ActiveSheet.Paste
'If required this code will delete the 'cut' row
wksData.Rows(i).Delete shift:=xlUp
'increment the output row
destinationRow = destinationRow + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next j
Next i
set wksData = Nothing
set wksDestination = Nothing
End Sub
There are other ways that will achieve the same outcome but this should give you and idea of how to use loops, sheets, ranges, etc.
The lastColumn and lastRow variables will find the the last column/row of data in the given columns/rows (i.e, in my code it finds the last column of data in row 1, and the last row of data in column A).
Also, you should get into the habit of debugging and stepping through code to identify errors and see exactly what each line is doing (this will also help you learn too).
You might find this of use.
It uses an array variable to store the values of the cells in the row to be moved. It does not use cut and paste, so only transfer the data values, and the code does not require activation of the required sheets.
The destination rows are in the same order as the rows on the original sheet.
The method used to find the last cell used in the row and column is more elegant than other answers given.
Option Explicit
Public Sub test_moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Set wksData = shtSheet1 ' Use the Codename "shtSheet1" for the worksheet. ie the value of the sheet property that is displayed as "(Name)"
Set wksDestination = shtSheet2
moveData wksData, wksDestination
End Sub
Public Sub moveData(wksData As Worksheet, wksDestination As Worksheet)
Dim ilastColumn As Integer
Dim ilastRow As Integer
Dim iRow As Long
Dim iColumn As Long
Dim iDestinationRowNumber As Integer
Dim MyArray() As Variant
Dim rngRowsToDelete As Range
iDestinationRowNumber = 1
ilastColumn = wksData.Cells(1, wksData.Columns.Count).End(xlToLeft).Column
ilastRow = wksData.Cells(wksData.Rows.Count, 1).End(xlUp).Row
ReDim MyArray(1, ilastColumn)
Set rngRowsToDelete = Nothing
For iRow = 1 To ilastRow Step 1 'No need to go 'up' the worksheet to handle 'deletes'
For iColumn = 1 To ilastColumn
If wksData.Cells(iRow, iColumn).Value = "" Then 'check for a blank cell in the current row
MyArray = wksData.Range(wksData.Cells(iRow, 1), wksData.Cells(iRow, ilastColumn)).Value
wksDestination.Range(wksDestination.Cells(iDestinationRowNumber, 1),
wksDestination.Cells(iDestinationRowNumber, ilastColumn) _
).Value = MyArray
'Store the rows to be deleted
If rngRowsToDelete Is Nothing Then
Set rngRowsToDelete = wksData.Rows(iRow)
Else
Set rngRowsToDelete = Union(rngRowsToDelete, wksData.Rows(iRow))
End If
'increment the output row
iDestinationRowNumber = iDestinationRowNumber + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next iColumn
Next iRow
If Not rngRowsToDelete Is Nothing Then
rngRowsToDelete.EntireRow.Delete shift:=xlUp
End If
Set rngRowsToDelete = Nothing
Set wksData = Nothing
Set wksDestination = Nothing
End Sub
' enjoy