I have an output excel file from another macro which has multiple sheets (named 100,101,102... etc.) Sheet numbers will vary depending on prior macro's output.
Also there is a sheet named sheet1 which has info about how many random rows should be selected from 100,101,102... etc.
I tried to merge/combine what i could find from similar macros but i guess the loop part is way over my head.
I will run the macro from another "main" excel. which will open related output xls.
Then it will lookup for random rows amount from sheet1 and then select that number of random rows in related sheet and move to next sheet. (I'm getting the correct amount from lookup (used index match))
But for randomized part i was not able to make it work for multiple sheets.
It does not matter if it selects and colors the rows or copies and pastes them to another sheet/wb. Both is ok, but I need to automate this process since i have so much data waiting.
The macro i have managed so far is below, since I'm a newbie there may be unrelated or unnecessary things.
Is it possible?
Sub RANDOM()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Worksheet
Dim Durat As Long
StartTime = Now()
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
Dim SheetN As Integer
Dim I As Long
FPath = ThisWorkbook.Path
Set mvn = Workbooks.Open(FileName:=ActiveWorkbook.Path & "\" &
Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value
& " Muavinbol" & ".xls")
SheetN = mvn.Worksheets.Count
Set SampleS = mvn.Sheets("Sheet1")
For Each Sh In mvn.Worksheets
Sh.Activate
If Sh.Name <> "Sheet1" Then
Dim lookupvalue As Integer
Dim ranrows As Integer
Dim randrows As Integer
lookupvalue = Cells(1, 1).Value
ranrows = Application.WorksheetFunction.Index(mvn.Sheets("Sheet1")_
.Range("S1:S304"), Application.WorksheetFunction.Match(lookupvalue,
mvn.Sheets("Sheet1").Range("$D$1:$D$304"), 0))
'MsgBox lookupvalue & " " & ranrows
End If
Next Sh
Durat = Round((Now() - StartTime) * 24 * 60 * 60, 0)
'MsgBox Durat & " seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Here is an example (i have integrated some code, adapted from other places, and added the references in to the code itself) I would welcome feedback from other users and can refine.
Sheet1 has the number of rows to return and the sheet names (i have used a short list)
The other sheets have some random data e.g. Sheet2
The code reads the sheet names into one array and the number of rows to randomly choose from each sheet into another array.
It then loops the sheets, generates the number of required random rows by selecting between the first and the start row in the sheet (this currently doesn't have error handling in case specified number of random rows exceeds available number ,but then could set numRows to lastRow. Union is used to collect these for the given sheet and they are copied to the next available row in the target sheet of another workbook. Union can't be used across worksheets sadly so a workaround has to be found, i chose this copy for each worksheet.
I have made some assumptions about where to copy from and to but have a play. I have also left some of your code in and currently set mnv = ThisWorkbook and the workbook to copy to is called otherWorkbook. Yours may be differently named and targeted but this was aimed at showing you a process for generating numbers and copying them in a loop.
Have used a function by Rory to test if the worksheet exists.
Example result:
Option Explicit
Public Sub RANDOM()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Worksheet
Dim Durat As Long
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
'Dim SheetN As Long
Dim i As Long
Dim otherWorkbook As Workbook
Dim targetSheet As Worksheet
Dim startTime As Date
Dim mnv As Workbook
Dim SampleS As Worksheet
startTime = Now()
FPath = ThisWorkbook.Path
'Set mvn = Workbooks.Open(Filename:=ActiveWorkbook.Path & "\" & Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value & " Muavinbol" & ".xls")
Set mnv = ThisWorkbook
Set otherWorkbook = Workbooks.Open("C:\Users\HarrisQ\Desktop\My Test Folder\Test.xlsx")
Set targetSheet = otherWorkbook.Sheets("TargetSheet")
Set SampleS = mnv.Worksheets("Sheet1")
Dim worksheetNames()
Dim numRandRows()
worksheetNames = SampleS.Range("$D$1:$D$3").Value
numRandRows = SampleS.Range("$S$1:$S$3").Value
Dim copyRange As Range
Dim currSheetIndex As Long
Dim currSheet As Worksheet
Dim selectedRows As Range
For currSheetIndex = LBound(worksheetNames, 1) To UBound(worksheetNames, 1)
If WorksheetExists(CStr(worksheetNames(currSheetIndex, 1))) Then
Set currSheet = mnv.Worksheets(worksheetNames(currSheetIndex, 1))
With currSheet
Dim firstRow As Long
Dim lastRow As Long
Dim numRows As Long
firstRow = GetFirstLastRow(currSheet, 1)(0) 'I am using Column A (1) to specify column to use to find first and last row.
lastRow = GetFirstLastRow(currSheet, 1)(1)
numRows = numRandRows(currSheetIndex, 1)
Set selectedRows = RandRows(currSheet, firstRow, lastRow, numRows) 'Union cannot span different worksheets so copy paste at this point
Dim nextTargetRow As Long
If IsEmpty(targetSheet.Range("A1")) Then
nextTargetRow = 1
Else
nextTargetRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row + 1
End If
selectedRows.Copy targetSheet.Cells(nextTargetRow, 1)
Set selectedRows = Nothing
End With
End If
Next currSheetIndex
Durat = Round((Now() - startTime) * 24 * 60 * 60, 0)
'MsgBox Durat & " seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Function RandRows(ByRef currSheet As Worksheet, ByVal firstRow As Long, ByVal lastRow As Long, ByVal numRows As Long) As Range
'http://www.ozgrid.com/VBA/RandomNumbers.htm
Dim iArr As Variant
Dim selectedRows As Range
Dim i As Long
Dim r As Long
Dim temp As Long
Application.Volatile
ReDim iArr(firstRow To lastRow)
For i = firstRow To lastRow
iArr(i) = i
Next i
For i = lastRow To firstRow + 1 Step -1
r = Int(Rnd() * (i - firstRow + 1)) + firstRow
temp = iArr(r)
iArr(r) = iArr(i)
iArr(i) = temp
Next i
Dim currRow As Range
For i = firstRow To firstRow + numRows - 1
Set currRow = currSheet.Cells.Rows(iArr(i))
If Not selectedRows Is Nothing Then
Set selectedRows = Application.Union(selectedRows, currRow)
Else
Set selectedRows = currRow
End If
Next i
If Not selectedRows Is Nothing Then
Set RandRows = selectedRows
Else
MsgBox "No rows were selected for copying"
End If
End Function
Private Function GetFirstLastRow(ByRef currSheet As Worksheet, ByVal colNum As Long) As Variant
'colNum determine which column you will use to find last row
Dim startRow As Long
Dim endRow As Long
endRow = currSheet.Cells(currSheet.Rows.Count, colNum).End(xlUp).Row
startRow = FirstUsedCell(currSheet, colNum)
GetFirstLastRow = Array(startRow, endRow)
End Function
Private Function FirstUsedCell(ByRef currSheet As Worksheet, ByVal colNum As Long) As Long
'Finds the first non-blank cell in a worksheet.
'https://www.excelcampus.com/library/find-the-first-used-cell-vba-macro/
Dim rFound As Range
On Error Resume Next
Set rFound = currSheet.Cells.Find(What:="*", _
After:=currSheet.Cells(currSheet.Rows.Count, colNum), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
If rFound Is Nothing Then
MsgBox currSheet & ":All cells are blank."
End
Else
FirstUsedCell = rFound.Row
End If
End Function
Function WorksheetExists(sName As String) As Boolean
'#Rory https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists
WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function
Since QHarr's code needed to have all worksheet names should exist in the workbook did not work for me in the end. But with merging it some other project's function i made it work.
Opens an output xlsx file in same folder,
Index&Match to find the random rows amount
loop through all sheets with random function
then paste all randomized rows into Sheet named RASSAL
It may be unefficient since I really dont have much info on codes, but guess i managed to modify it into my needs.
Open to suggestions anyway and thanks to #QHarr very much for His/Her replies.
Sub RASSALFNL()
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Dim Durat As Long
startTime = Now()
Dim Sht As Worksheet
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
Dim SheetN As Long
Dim i As Long
Dim lookupvalue As Long
Dim indexrange As Range
Dim matchrange As Range
Dim ranrows As Long
Dim firstRow As Long
Dim lastRow As Long
Dim numRows As Long
Dim sayf As String
Dim nextTargetRow As Long
Dim Rassal As Worksheet
Dim rngToCopy As Range
Dim sampleCount As Long
Dim ar() As Long
Dim total As Long
Dim rowhc As Long
FPath = ThisWorkbook.Path
Set mvn = Workbooks.Open(FileName:=ActiveWorkbook.Path & "\" &
Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value
& " Muavinbol" & ".xlsx")
SheetN = mvn.Worksheets.count
Set SampleS = mvn.Sheets("Sheet1")
Set Rassal = Worksheets.Add
Rassal.Name = "RASSAL"
Set indexrange = SampleS.Range("$S$8:$S$304")
Set matchrange = SampleS.Range("$D$8:$D$304")
mvn.Activate
For Each Sht In mvn.Worksheets
Sht.Activate
If Sht.Name = "Sheet1" Or Sht.Name = "Sayfa1" Or Sht.Name = "RASSAL"
Then
'do nothing
Else
lookupvalue = Sht.Cells(1, 1).Value
ranrows = Application.WorksheetFunction.Index(indexrange,
Application.WorksheetFunction.Match(lookupvalue, matchrange, 0))
With Sht
firstRow = GetFirstLastRow(Sht, 1)(0)
lastRow = GetFirstLastRow(Sht, 1)(1)
numRows = ranrows
sayf = Sht.Name
'MsgBox sayf & " " & firstRow & " " & lastRow & " " &
ranrows
If numRows = 0 Then
'do nothing
Else
ar = UniqueRandom(numRows, firstRow, lastRow)
Set rngToCopy = .Rows(ar(0))
For i = 1 To UBound(ar)
Set rngToCopy = Union(rngToCopy, .Rows(ar(i)))
Next
If IsEmpty(mvn.Sheets("RASSAL").Range("A1")) Then
nextTargetRow = 1
Else
nextTargetRow =
mvn.Sheets("RASSAL").Cells(mvn.Sheets("RASSAL").Rows.count,
"A").End(xlUp).Row + 1
End If
rngToCopy.Copy Rassal.Cells(nextTargetRow, 1)
Set rngToCopy = Nothing
End If
End With
End If
Next Sht
rowhc = Rassal.Cells(Rows.count, 1).End(xlUp).Row
Durat = Round((Now() - startTime) * 24 * 60 * 60, 0)
MsgBox rowhc & " " & "random selections made in" & " " & Durat & "
seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Function GetFirstLastRow(ByRef Sht As Worksheet, ByVal colNum As
Long) As Variant
'colNum determine which column you will use to find last row
Dim firstRow As Long
Dim lastRow As Long
lastRow = Sht.Cells(Sht.Rows.count, colNum).End(xlUp).Row
firstRow = FirstUsedCell(Sht, colNum)
GetFirstLastRow = Array(firstRow, lastRow)
End Function
Private Function FirstUsedCell(ByRef Sht As Worksheet, ByVal colNum As
Long) As Long
Dim rFound As Range
On Error Resume Next
Set rFound = Sht.Cells.Find(What:="*", _
After:=Sht.Cells(Sht.Rows.count,
colNum), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
If rFound Is Nothing Then
'do Nothing MsgBox Sh & ":All cells are blank."
End
Else
FirstUsedCell = rFound.Row
End If
End Function
Function UniqueRandom(ByVal numRows As Long, ByVal a As Long, ByVal b As
Long) As Long()
Dim i As Long, j As Long, x As Long
ReDim arr(b - a) As Long
Randomize
For i = 0 To b - a: arr(i) = a + i: Next
If b - a < count Then UniqueRandom = arr: Exit Function
For i = 0 To b - a 'Now we shuffle the array
j = Int(Rnd * (b - a))
x = arr(i): arr(i) = arr(j): arr(j) = x ' swap
Next
' After shuffling the array, we can simply take the first portion
If numRows = 0 Then
ReDim Preserve arr(0)
Else
ReDim Preserve arr(0 To numRows - 1)
On Error Resume Next
End If
'sorting, probably not necessary
For i = 0 To count - 1
For j = i To count - 1
If arr(j) < arr(i) Then x = arr(i): arr(i) = arr(j): arr(j) = x '
swap
Next
Next
UniqueRandom = arr
End Function
I need a VBA code for a simple copy and (paste) transpose row data and results looks like below
Row data
Final results
Kindly help me.
I hope you accept answer and upvote
Try this
Option Explicit
Sub Test()
Dim rng As Excel.Range
Set rng = Sheet1.Range("A1").CurrentRegion
Dim dicMaster As Object
Set dicMaster = VBA.CreateObject("Scripting.Dictionary")
Dim lRowLoop As Long
For lRowLoop = 1 To rng.Rows.Count
Dim vLeft As Variant
vLeft = rng.Cells(lRowLoop, 1)
Dim vRight As Variant
vRight = rng.Cells(lRowLoop, 2)
Dim dicSub As Object
If Not dicMaster.exists(vLeft) Then
Set dicSub = VBA.CreateObject("Scripting.Dictionary")
dicMaster.Add vLeft, dicSub
End If
Set dicSub = dicMaster.Item(vLeft)
dicSub.Add dicSub.Count, vRight
Next
'* find the widest
Dim lWidest As Long
lWidest = 0
Dim vKeyLoop As Variant
For Each vKeyLoop In dicMaster.Keys
Dim lCount As Long
lCount = dicMaster(vKeyLoop).Count
If lWidest < lCount Then lWidest = lCount
Next
'* so now dimension results
ReDim vResults(1 To dicMaster.Count, 1 To lWidest + 1) As Variant
Dim lRowIndex As Long
For Each vKeyLoop In dicMaster.Keys
lRowIndex = lRowIndex + 1
vResults(lRowIndex, 1) = vKeyLoop
Set dicSub = dicMaster.Item(vKeyLoop)
Dim lColIndex As Long
lColIndex = 2
Dim vItemLoop As Variant
For Each vItemLoop In dicSub.Items
vResults(lRowIndex, lColIndex) = vItemLoop
lColIndex = lColIndex + 1
Next vItemLoop
Next
Sheet2.Cells(1, 1).Resize(dicMaster.Count, lWidest + 1) = vResults
End Sub
I have written the following code, which I was hoping to use to look up values from columns 21 through to the last row in another sheet and return them to this sheet based on a value in column A in this sheet and column B in the other sheet.
When I use the code below I get an worksheet error. Could you please tell me why?
Dim wsMvOld As Worksheet
Dim wsMvFile As Worksheet
Dim wsColumn As Long
Dim lastColumn As Long
Dim y As Integer
Dim i As Integer
Dim FrRngCount As Range
Set wsMvOld = wbMVRVFile.Worksheets(2)
wbMVRVFile.Worksheets.Add().Name = "MV " & Format(DateSerial(Year(Date), Month(Date), 0), "dd-mm-yy")
Set wsMvFile = wbMVRVFile.ActiveSheet
Set FrRngCount = wsMvFile.Range("A:A")
y = Application.WorksheetFunction.CountA(FrRngCount)
lastColumn = wsMvFile.Cells(1, wsMvFile.Columns.Count).End(xlToLeft).Column
For wsColumn = 21 To lastColumn
For i = 2 To y
wsMvFile.Columns(wsColumn).Cells(i) = Application.Index(wsMvOld.Range(wsColumn), Application.Match(wsMvFile.Range("A" & i), wsMvOld.Range("B:B"), 0))
Next i
Next wsColumn
End Sub
Thanks for your help!
This untested, but it replaces the worksheet function to vba find method.
Private Sub Worksheet_Activate()
Dim wsMvOld As Worksheet
Dim wsMvFile As Worksheet
Dim wsColumn As Long
Dim lastColumn As Long
Dim y As Integer
Dim i As Integer
Dim FrRngCount As Range
Set wsMvOld = wbMVRVFile.Worksheets(2)
Set wsMvFile = wbMVRVFile.Worksheets.Add()
wsMvFile.Name = "MV " & Format(DateSerial(Year(Date), Month(Date), 0), "dd-mm-yy")
Set FrRngCount = wsMvFile.Range("A:A")
y = Application.WorksheetFunction.CountA(FrRngCount)
lastColumn = wsMvFile.Cells(1, wsMvFile.Columns.Count).End(xlToLeft).Column
For i = 2 To y
Dim rng As Range
Set rng = sMvOld.Range("B:B").Find(wsMvFile.Range("A" & i))
For wsColumn = 21 To lastColumn
If Not rng Is Nothing Then
wsMvFile.Columns(wsColumn).Cells(i).Value = wsMvOld.Cells(rng.Row, wsColumn)
Else
wsMvFile.Columns(wsColumn).Cells(i).Value = 0
End If
Next wsColumn
Next i
End Sub
I want to copy a range of cells from Workbook1.xlsm and Insert them in Workbook2.xltm.
I will need to insert enough rows in Workbook2 to 'cope' with the size of the data, which will vary. Thanks to jspek I've the following macro but this doesn't insert the rows in Workbook2.
From much Googling I came to this . All I can see is that I need to use .Resize.
My Trial Macro
sub rangeCopy()
Dim sourceRange As Range, loopRange As Range
Dim targetRange As Range
Dim lastRow As Long
Dim sourceCounter As Long
Dim targetCounter As Long
Dim outString As String
Dim startRow As Long
Dim startCol As Long
Dim endCol As Long
Dim colCounter As Long
Set sourceRange = Sheets("Input Sheet").Range("A9:C800")
Set targetRange = Workbooks.Open("C:\Users\j\Documents\Workbook2.xltm").Sheets("Quote").Range("A4")
startRow = sourceRange.Row
lastRow = sourceRange.Rows.Count
startCol = sourceRange.Column
endCol = sourceRange.Columns.Count - 1
Set loopRange = sourceRange.Parent.Cells(startRow, startCol)
For colCounter = 0 To endCol
targetCounter = 0
For sourceCounter = 0 To lastRow - 1
outString = Trim(loopRange.Offset(sourceCounter, colCounter).Value)
While (Trim(targetRange.Offset(targetCounter, colCounter).Value) <> "")
targetCounter = targetCounter + 1
Wend
targetRange.Offset(targetCounter, colCounter).Value = outString
Next
Next
End Sub
Just the idea of what I was trying to suggest you need to make changes and debug it to suit it to your needs
sub rangeCopy()
Dim p As long
Set targetRange = Workbooks.Open("C:\Users\j\Documents\Workbook2.xltm").Sheets("Quote").Range("A4")
Dim FRow As Long
Dim m As Long
m =Sheets("Input Sheet").Rows.Count
FRow = Sheets("Input Sheet").Range("A" & m).End(xlUp).Row
Set sourceRange = Sheets("Input Sheet").Range("A9:C" &FRow)
sourceRange.Copy
Sheets("Quote").Rows("4:4").Select Selection.Insert Shift:=xlDown
p= FRow + 5
Sheets("Quote").Rows("4:" & p).Copy
Sheets("Quote").Rows("4:4").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub
I have 2 separate sheets, lets call them sheet A, sheet B. I have data in sheet B which is also in sheet A. I want to find those rows that are equal and remove them from sheet B.
I cannot combine the 2 sheets and use filters because I'm doing dynamic SQL to query different data.
Each sheet has a unique key column
I'm ok with VBA suggestions and Excel formulas. Just as long as I don't combine sheets.
Thank so much guys!
Sorry, apparently I made a mistake. There is an infinite loop here somewhere. This is Ben's answer btw. I just reposted a compilable version.
Sub CleanDupes()
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim keyColA As String
Dim keyColB As String
Dim rngA As Range
Dim rngB As Range
Dim intRowCounterA As Integer
Dim intRowCounterB As Integer
keyColA = "A"
keyColB = "A"
intRowCounterA = 1
intRowCounterB = 1
Set wsA = Worksheets("Sheet2")
Set wsB = Worksheets("Sheet1")
Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value)
Set rngA = wsA.Range(keyColA & intRowCounterA)
intRowCounterB = 1
Do While Not IsEmpty(wsB.Range(keyColB & intRowCounterB).Value)
Set rngB = wsB.Range(keyColB & intRowCounterB)
If rngA.Value = rngB.Value Then
Rows(intRowCounterB).EntireRow.Delete
intRowCounterB = intRowCounterB - 1
End If
intRowCounterB = intRowCounterB + 1
Loop
intRowCounterA = intRowCounterA + 1
Loop
End Sub
Sub CleanDupes()
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim keyColA As String
Dim keyColB As String
Dim rngA As Range
Dim rngB As Range
Dim intRowCounterA As Integer
Dim intRowCounterB As Integer
Dim strValueA As String
keyColA = "A"
keyColB = "B"
intRowCounterA = 1
intRowCounterB = 1
Set wsA = Worksheets("Sheet A")
Set wsB = Worksheets("Sheet B")
Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value)
intRowCounterB = 1
Set rngA = wsA.Range(keyColA & intRowCounterA)
strValueA = rngA.Value
Do While Not IsEmpty(wsB.Range(keyColB & intRowCounterB).Value
Set rngB = wsB.Range(keyColB & intRowCounterB)
If strValueA = rngB.Value Then
'Code to delete row goes here, but I'm not sure exactly'
'what it is.'
wsB.Rows(intRowCounterB).Delete
intRowCounterB = intRowCounterB - 1
End If
intRowCounterB = intRowCounterB + 1
Loop
intRowCounterA = intRowCounterA + 1
Loop
End Sub
That should get you started.