We are trying this trick for a while !
We have a range of 'x' rows, and we would like to make a random sample of 35 rows by hiding all others.
The difficult mission for us is to make all random row unique (to avoid hiding a row already hide).
For that, we tried to make a loop, with a check if the row is already hide.
We tried to make this code, but it's not working :
Function randSample(Rg As Range) As Range
Set randSample = Rg.Rows(Int(Rnd * Rg.Rows.Count) + 1)
End Function
Sub sampling()
Dim N As Long, i As Integer, Raw As Range, myRange As Range, sampleRangeCount As Long
N = Cells(12, 1).End(xlDown).Row
Set myRange = Range("A12:AW" & N)
sampleRangeCount = myRange.Rows.Count - 35
Application.ScreenUpdating = False
Randomize
For i = 1 To sampleRangeCount
Do
Set Raw = randSample(myRange)
Loop Until Raw.EntireRow.Hidden = False
Raw.EntireRow.Hidden = True
Next
Application.ScreenUpdating = True
End Sub
Could you help us for that? Where are we wrong?
Thank you a lot!
Kevin
Related
I have a set of information in the same column (H27:O27) in one sheet ("P1-FR1") and would like to paste individual values to another sheet (AQ6:AX6) ("Übersicht GESAMT")
I'm trying to use a For loop but the values just copy one after the other (in the same cell) instead of copying one in each cell. This is my code:
Sub CopyValues()
Dim i As Long
Dim j As Long
Dim Wert As Long
For i = 8 To 14
Wert = Sheets("P1-FR1").Cells(27, i)
For j = 43 To 50
Sheets("Übersicht GESAMT").Cells(6, j) = Wert
Next j
Next i
End Sub
You don't need a double For loop in this case at all. A simple .Value copy will work. The code below shows two examples with different ways to accomplish what you want. (TIP: it always helps me to be VERY clear on how I name the variables, it helps to keep track of where all the data is coming and going)
Option Explicit
Sub CopyTheValues()
Dim datenQuelle As Range
Dim datenZiel As Range
Set datenQuelle = ThisWorkbook.Sheets("P1-FR1").Range("H27:O27")
Set datenZiel = ThisWorkbook.Sheets("Übersicht GESAMT").Range("AQ6:AX6")
'--- method 1 - works because the ranges are the same size and shape
datenZiel.Value = datenQuelle.Value
'--- method 2 - for loops
' index starts at 1 because the Range is defined above
' (and we don't care what rows/columns are used)
Dim j As Long
For j = 1 To datenQuelle.Columns.Count
datenZiel.Cells(1, j).Value = datenQuelle.Cells(1, j).Value
Next i
End Sub
Copying By Assignment
Option Explicit
Sub CopyValuesNoLoop()
ThisWorkbook.Worksheets("Übersicht GESAMT").Range("AQ6:AX6").Value _
= ThisWorkbook.Worksheets("P1-FR1").Range("H27:O27").Value
End Sub
Sub CopyValuesQuickFix()
Dim j As Long: j = 43
Dim i As Long
For i = 8 To 14
ThisWorkbook.Worksheets("Übersicht GESAMT").Cells(6, j).Value _
= ThisWorkbook.Worksheets("P1-FR1").Cells(27, i).Value
j = j + 1
Next i
End Sub
The nesting of the for loops is causing your issue. It is causing each cell from the first sheet to be copied to all cells on the second sheet.
You only need one loop to perform the copy. Something like this should work.
Sub CopyValues()
Dim i As Long
For i = 8 To 15
Sheets("Übersicht GESAMT").Cells(6,i+35) = Sheets("P1-FR1").Cells(27,i)
Next i
End Sub
I have a lengthy code unable to share the 8000+ liner code completely, The code runs through loops multiple times row by row, if there are 10000+ rows then loop runs 10000+ times.
Since the code is too lengthy I am sharing a part of it were I feel it can shorten the time taken, But I am missing a loop in it and how do I include that Is my query for now.
I’ll be sharing the original code and very next is the replacement code kindly check and let me know we’re and how to include.
Original code:
For i = 2 To endlineMM
If worksheets(“MM Source”).cells(I,9).value = “registered locked” or worksheets(“MM Source”).cells(i,9).value = “registered unlocked” Then
For j = 3 to endlineDHDO
If instr(Lcase(worksheets(“DHDO”).cells(j,2).value),Lcase(Worksheets(“MM Source”).cells(i,2).value)) <> 0 Then
If Lcase(Worksheets(“MM Source”).cells(i,2).value) = Lcase(worksheets(“DHDO”).cells(j,2).value) Then
Found missing = True
Exit For
Else if j= EndlineDHDO And Lcase(Worksheets(“MM Source”).cells(i,2).value)<>
Lcase(worksheets(“DHDO”).cells(j,2).value) Then
Foundmissing = false
End if
Next j
If foundmissing = False Then
Etc......
Replacement code:
For i = 2 to endlineMM
If worksheets(“MM Source”).cells(I,9).value = “registered locked” or worksheets(“MM Source”).cells(i,9).value = “registered unlocked” Then
Test_ID = Worlsheets(“MM Source”).cells(i,2).value
With sheets(“DHDO”).Range(“B:B“)
Set prg = .Find(Test_ID, LookIn:=xlvalues)
If prg is nothing then
Foundmissing =true
Exit for
Else
Foundmissing = false
End if
End with
If foundmissing = false Then
Etc......
If you observe above from original code it has “i“ as well as “j” but in replacement code I am missing “j”
How can I fix my Replacement code
let me know how to edit the Replacement code please
Generally speaking, your code will run a lot faster if you use Ranges and Arrays rather than individual Cells.
For example, if you were to take a spreadsheet and fill columns A1:B10000, with numeric data, and then compare the performance of the two following codes:
Dim data As Variant
Dim output(10000) As Double
Dim i As Integer
data = Application.Transpose(Application.Transpose(Range("A1", "B10000")))
For i = 1 To 10000
output(i - 1) = data(i, 1) + data(i, 2)
Next
Range("C1", "C10000").Value = Application.Transpose(output)
and
Dim i As Integer
For i = 1 To 10000
Cells(i, 3).Value = Cells(i, 1).Value + Cells(i, 2).Value
Next
You will notice that the first variation is considerably faster.
By way of explanation Application.Transpose is necessary to assign the range to an array. It needs to be doubled in the first case, because it is a two-dimensional array.
Here is a sample that will filter the MM Source sheet, then loop through the visible cells finding cells in DHDO sheet
Sub Do_It()
Dim sh As Worksheet, ws As Worksheet
Dim rng As Range, c As Range
Dim a As Range
Set sh = Sheets("MM Source")
Set ws = Sheets("DHDO")
Application.ScreenUpdating = False
With sh
Set rng = .Range("I2:I" & .Cells(.Rows.Count, "I").End(xlUp).Row)
.Columns("I:I").AutoFilter Field:=1, Criteria1:= _
"=registered locked", Operator:=xlOr, Criteria2:="=registered unlocked"
For Each c In rng.SpecialCells(xlCellTypeVisible).Cells
Set a = ws.Range("B:B").Find(c.Offset(, -7), LookIn:=xlValues)
If Not a Is Nothing Then
'MsgBox "Do nothing"
Else
'MsgBox "Do something"
c.Interior.Color = vbGreen
End If
Next c
.AutoFilterMode = False
End With
End Sub
I want to delete entire rows of data, if the formula matches the set value.
I am running a check (example: sum of three columns = 0?) through a set of 17K records. The code takes around 20 minutes to complete.
Dim currentRow As Integer
Dim rowCheck As Long
Dim ws As Worksheet
Set ws = ActiveSheet
For currentRow = ws.UsedRange.Rows.Count To 2 Step -1
rowCheck = Application.WorksheetFunction.Sum(Cells(currentRow, 5), Cells(currentRow, 6), Cells(currentRow, 7))
Select Case rowCheck
Case 0
ws.Rows(currentRow).Delete ' it takes around 20 minutes to complete with 17K records to run through
Case Else
End Select
Next
Set ws = Nothing
The code is working, however, it seems, I am doing something wrong, as I believe the code should work so much faster with given set of data (only 17K records).
Is there a way to optimize the deletion line?
Having to go through it line for line isn't the fast way to do this. You would be better off with a temporary helper column which calculates the sum. You can then filter the range on this column and delete all rows that match your criteria at once. So something like this. (assuming Column H is empty)
Dim currentRow As Integer
Dim rowCheck As Long
Dim ws As Worksheet
Dim lastRow as integer
Set ws = ActiveSheet
lastRow = ws.UsedRange.Rows.Count
ws.range("h2").formula = "=sum(e2:g2)"
ws.range("h2").autofill destination:= ws.range("h2:h" & lastRow)
ws.range("a1:h1").autofilter field:=8, criteria1:="0"
ws.range("a2:h" & lastRow).SpecialCells(xlCellTypeVisible).entirerow.delete
ws.autofiltermode = false
ws.range("h1:h" & lastRow).clearcontents
set ws = Nothing
Edit: You could also filter columns E, F, and G on 0 but that only works if all values are 0 or positive. Doing it the way I suggested gives you more control, because you can easily adjust the formula you put in cell H2.
It will be much faster to find all the rows that you want to delete, select all the rows, and delete them in one go, instead of doing it row by row.
let's say you found you wanted to delete rows 35, 37, 39, and 40 then the code will be something like
for each row in row_to_evaluate
delete_row = evaluate(row)
if delete_row = True then Delete_Row_List = Delete_Row_List & "," & row
next
'Example: Delete_Row_List = "35,37,39,40"
Rows(Delete_Row_List).Delete Shift:=xlUp
also remember application.screenupdating = False before you run the code and application.screenupdating = True after you run it for a bit better performance.
hope it helps
EDIT:
Ah I see an answer before mine basically recommended the same
It just occurred to me to speed up your code substantially. I assumed that you have to use the delete rows capability, but it will actually be much faster to do the following (note this is pseudo code, panel beat to work for you):
with thisworkbook.worksheets("Sheet1")
redim New_Sheet(1 to nr_rows, 1 to nr_columns) as variant
Old_Sheet = .range(.cells(1,1),.cells(nr_rows,nr_columns)
'keep the headers
for col = 1 to nr_columns
New_Sheet(1,col) = Old_Sheet(1,col)
next col
k = 1
for row = 2 to nr_rows 'start at 2 to protect the headers
keep_row = evaluate_row(row,Old_sheet) 'this function must evaluate the row. return True if you want to keep the row, return false if you want to delete it
if keep_row then
k = k+1
for col = 1 to nr_col
New_sheet(k,col) = Old_Sheet(row,col)
next col
next row
.range(.cells(1,1),.cells(nr_rows,nr_columns) = New_Sheet
end with
I am a novice when it comes to writing macro code in VBA. I'm working with Excel 2010, and I think I have a simple problem. I want to hide rows in my worksheet that meet the condition of having a zero sum result in column AJ. I was able to figure how to do this for one row and then repeat for each subsequent row, but I know there must a better/more efficient means of writing this. Can anyone help me re-word this code so that it considers the range of rows 8-14 all together rather than considering each row one at a time? This would reduce my run-time and decrease the possibility for errors. Thank you in advance!
Sub Hide_1()
'
' Master Macro
If ActiveSheet.Range("AJ8") = 0 Then
Rows("8").EntireRow.Hidden = True
End If
If ActiveSheet.Range("AJ9") = 0 Then
Rows("9").EntireRow.Hidden = True
End If
If ActiveSheet.Range("AJ10") = 0 Then
Rows("10").EntireRow.Hidden = True
End If
If ActiveSheet.Range("AJ11") = 0 Then
Rows("11").EntireRow.Hidden = True
End If
If ActiveSheet.Range("AJ12") = 0 Then
Rows("12").EntireRow.Hidden = True
End If
If ActiveSheet.Range("AJ13") = 0 Then
Rows("13").EntireRow.Hidden = True
End If
If ActiveSheet.Range("AJ14") = 0 Then
Rows("14").EntireRow.Hidden = True
End If
End Sub
This will loop through your range and hide the row where the value is 0:
Sub HideRows()
Dim rng As Range, cl As Range
Set rng = Range("AJ8:AJ14")
For Each cl In rng
If cl = 0 Then
cl.EntireRow.Hidden = True
End If
Next cl
End Sub
How about:
Public Sub HideEntireRow(cellToCheck As range, valueToHide As Variant)
If cellToCheck.Value2 = valueToHide Then cellToCheck.EntireRow.Hidden = True
End Sub
Public Sub Hide_2()
Dim cell As range
For Each cell In ActiveSheet.range("AJ10:AJ14")
Call HideEntireRow(cell, 0)
Next cell
End Sub
For a range as small as you are working with, an autofilter will not offer any visible performance boost, but you should use autofilters by default rather than loops. There are plenty of instances where loops are necessary, but this doesn't appear to be one of them.
Here is how you can filter your sheet (starting in row 8), hiding any rows that have a 0 in column AJ. Note that I am calculating the last row in your sheet. If you need to hard-code a specific range, you can easily modify this:
Sub FilterZeroRows()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
lastRow = ws.Range("AJ" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("AJ8:AJ" & lastRow)
' keep any rows that don't have 0 visible
rng.AutoFilter field:=1, Criteria1:="<>0"
End Sub
I have a little experience with VBA, and I would really appreciate any help with this issue. In a basic sense, I need to convert 2 columns of data in sheet 1 to rows of data in sheet 2.
It currently looks like this in Excel:
And I need it to look like this:
I've already written the code to transfer the headings over to sheet 2, and it works fine. I'm just having issues with transferring the actual values in the correct format. Right now, the body of my code is
ws.Range("B3").Copy
ws2.Range("C2").PasteSpecial xlPasteValues
ws.Range("B4").Copy
ws2.Range("D2").PasteSpecial xlPasteValues
ws.Range("B5").Copy
ws2.Range("E2").PasteSpecial xlPasteValues
ws.Range("B6").Copy
ws2.Range("F2").PasteSpecial xlPasteValues
continued on and on. However, this really won't work, as the actual document I'm working on has tens of thousands of data points. I know there's a way to automate this process, but everything I've tried has either done nothing or given an error 1004.
Any help with this would be greatly appreciated!!
Edit: There are hundreds of little sections of data, each 18 rows long (1 row for the frame #, 1 row for the time, and 1 row for each of the 16 channels). I'm trying to get it into a loop with a step size of 18. Is that possible? I'm fine with loops, but I've never done a loop with copying and pasting cell values
Try this code:
Dim X() As Variant
Dim Y() As Variant
X = ActiveSheet.Range("YourRange").Value
Y = Application.WorksheetFunction.Transpose(X)
Also check out this link: Transpose a range in VBA
This method leverages loops and arrays to transfer the data. It isn't the most dynamic method but it gets the job done. All the loops use existing constants, so if your data set changes you can adjust the constants and it should run just fine. Make sure to adjust the worksheet names to match the names you are using in your excel document. In effect, what this is doing is loading your data into an array and transposing it onto another worksheet.
If your data set sizes change quite a bit, you will want to include some logic to adjust the loop variables and array size declarations. If this is the case, let me know and I'll figure out how to do that and post an edit.
Sub moveTimeData()
Set source = ThisWorkbook.Sheets("RawData")
Set dest = ThisWorkbook.Sheets("TransposeSheet")
Const dataSetSize = 15
Const row15Start = 3
Const row15End = 18
Const row30Start = 21
Const row30End = 36
Const colStart = 2
Const destColStart = 2
Const dest15RowStart = 2
Const dest30RowStart = 3
Dim time15Array() As Integer
Dim time30Array() As Integer
ReDim time15Array(0 To dataSetSize)
ReDim time30Array(0 To dataSetSize)
Dim X As Integer
Dim Y As Integer
Dim c As Integer
c = 0
For X = row15Start To row15End
time15Array(c) = source.Cells(X, colStart).Value
c = c + 1
Next X
c = 0
For X = row30Start To row30End
time30Array(c) = source.Cells(X, colStart).Value
c = c + 1
Next X
For X = 0 To dataSetSize
dest.Cells(dest15RowStart, X + destColStart).Value = time15Array(X)
Next X
For X = 0 To dataSetSize
dest.Cells(dest30RowStart, X + destColStart).Value = time30Array(X)
Next X
End Sub
EDIT-> I think this is what you are looking for after reading your edits
Sub moveTimeData()
Set source = ThisWorkbook.Sheets("RawData")
Set dest = ThisWorkbook.Sheets("TransposeSheet")
Const numberDataGroups = 4
Const dataSetSize = 15
Const stepSize = 18
Const sourceRowStart = 3
Const sourceColStart = 2
Const destColStart = 2
Const destRowStart = 2
Dim X As Integer
Dim Y As Integer
Dim currentRow As Integer
currentRow = destRowStart
For X = 0 To numberDataGroups
For Y = 0 To dataSetSize
dest.Cells(currentRow, Y + destColStart).Value = source.Cells((X * stepSize) + (Y + sourceRowStart), sourceColStart)
Next Y
currentRow = currentRow + 1
Next X
End Sub
Now the key to this working is knowing how many groups of data you are dealing with after the data dump. You either need to include logic for detecting that or adjust the constant called numberDataGroups to reflect how many groups you have. Note: I leveraged a similar technique for traversing arrays that have their data stored in Row Major format.
Use Copy, then Paste Special+Transpose to turn your columns into rows:
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
Try this:
Sub TansposeRange()
Dim InRange As Range
Dim OutRange As Range
Dim i As Long
Set InRange = Sheet1.Range("B3:B10002")
Set OutRange = Sheet2.Range("C2")
InRange.Worksheet.Activate
InRange.Select
Selection.Copy
OutRange.Worksheet.Activate
OutRange.Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End Sub
This is a way to do it using a loop, here illustrated with a step of 2
Notice that you have to specify the OutRange precisely the correct size (here NTR2 is the 10001's cell of the 2nd row).
Sub TansposeRange()
Dim InRange As Range
Dim OutRange As Range
Dim i As Long
Set InRange = Sheet1.Range("B3:B10002")
Set OutRange = Sheet2.Range("C2:NTR2")
For i = 1 To 10000 Step 2
OutRange.Cells(1, i) = InRange.Cells(i, 1)
Next i
End Sub
'The following code is working OK
Sub TansposeRange()
'
' Transpose Macro
'
Dim wSht1 As Worksheet
Dim rng1 As Range
Dim straddress As String
Set wSht1 = ActiveSheet
On Error Resume Next
Set rng1 = Application.InputBox(Prompt:="Select Columns or Rows to transpose", _
Title:="TRANSPOSE", Type:=8)
If rng1 Is Nothing Then
MsgBox ("User cancelled!")
Exit Sub
End If
straddress = InputBox(Prompt:="Full cell Address as Sheet2!A1", _
Title:="ENTER Full Address", Default:="Sheet1!A1")
If straddress = vbNullString Then
MsgBox ("User cancelled!")
Exit Sub
End If
Application.ScreenUpdating = False
rng1.Select
rng1.Copy
On Error GoTo 0
'MsgBox straddress
Range(straddress).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.ScreenUpdating = True
End Sub