I am trying to get my macro(next word) to select a random word from a list and then another macro(definition) does a vlookup to return the definition. When I select the macro to grab a new word I need it to clear the macro for the definition so that I cant see it until i select the definition button. Right now i get runtime error 1004 and it highlights my .clearcontent code at the end.
Sub showRandomWord()
Dim ws As Worksheet, ws2 As Worksheet
Dim stRow As Long, endRow As Long, dataCol As Long
Dim dispRow As Long, dispCol As Long
Set ws = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
stRow = 2
dataCol = 1
dispRow = 2
dispCol = 2
With ws
endRow = .Cells(.Rows.Count, dataCol).End(xlUp).Row
End With
ws2.Cells(dispRow, dispCol).Value =
ws.Cells(Application.RandBetween(stRow, endRow), dataCol).Value
Worksheets("Sheet2").Range("J2").ClearContents
End Sub
Use MergeArea?
Sub showRandomWord()
Dim ws As Worksheet, ws2 As Worksheet
Dim stRow As Long, endRow As Long, dataCol As Long
Dim dispRow As Long, dispCol As Long
Set ws = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
stRow = 2
dataCol = 1
dispRow = 2
dispCol = 2
With ws
endRow = .Cells(.Rows.Count, dataCol).End(xlUp).Row
End With
ws2.Cells(dispRow, dispCol).Value = ""
ws.Cells(Application.RandBetween(stRow, endRow), dataCol).Value
ws2.Range("J2").MergeArea.ClearContents
End Sub
Related
I have a list of values in cells A1:A75, and a button to randomly select one and display it in cell D3:
Sub BingoGen()
Dim ws As Worksheet
Dim stRow As Long, endRow As Long, dataCol As Long
Dim dispRow As Long, dispCol As Long
Set ws = Sheets("BingoHome")
stRow = 2
dataCol = 1
dispRow = 3
dispCol = 4
With ws
endRow = .Cells(.Rows.Count, dataCol).End(xlUp).Row
.Cells(dispRow, dispCol).Value = _
.Cells(Application.RandBetween(stRow, endRow), dataCol).Value
End With
I would like to alter this to begin by showing the value in A1 and work down the list with each button click.
I have another macro button that will randomize this list of values.
I would use a static variable to store the location the presently referenced cell.
Sub BingoGen()
Dim ws As Worksheet
Dim stRow As Long, endRow As Long, dataCol As Long
Dim dispRow As Long, dispCol As Long
Static dataRow As Integer
Set ws = Sheets("BingoHome")
stRow = 2
dataCol = 1
dispRow = 3
dispCol = 4
With ws
'if you will always have 75 rows I would just use endRow = 75
endRow = .Cells(.Rows.Count, dataCol).End(xlUp).Row
'if the data row is undefined or larger than the end row
If dataRow < 1 Or dataRow > endRow Then
dataRow = 1
'otherwise (1<= dataRow <= endRow) index dataRow by 1
Else
dataRow = dataRow + 1
End If
.Cells(dispRow, dispCol).Value = .Cells(dataRow, dataCol).Value
End With
Also, out of curiosity is there a reason that you are typing all of your variables as Long, when they would easily fit in an Integer?
I am trying to hide multiple rows in an excel worksheet which are empty using following code however i am getting error message "Argument not optional". What could be wrong in the code?
Sub Attendance_Manday()
Dim sht1 As Worksheet
Dim row_count, col_count As Integer
Dim mainrange As Range
Dim startcell As Range
Set startcell = Range("B1")
Set sht1 = Sheets("Mandays")
row_count = Sheets("Mandays").Cells(Rows.Count, startcell.Column).End(xlUp).Row
col_count = Sheets("Mandays").Cells(startcell.Row, Columns.Count).End(xlToLeft).Offset(1, -2).Column
Set mainrange = sht1.Range(startcell.Address & ":" & sht1.Cells(row_count, col_count).Address)
mainrange.Range.SpecialCells(xlCellTypeBlanks).Rows.Hidden = True
End Sub
Based on your code and assuming first row in your sheet is never empty you could do something like that
Sub Attendance_Manday()
Dim sht1 As Worksheet
Dim row_count As Long, col_count As Long
Dim mainrange As Range
Dim startcell As Range
Set startcell = Range("B1")
Set sht1 = Sheets("Mandays")
row_count = Sheets("Mandays").Cells(Rows.Count, startcell.Column).End(xlUp).Row
col_count = Sheets("Mandays").Cells(startcell.Row, Columns.Count).End(xlToLeft).Offset(1, -2).Column
Set mainrange = sht1.Range(startcell.Address & ":" & sht1.Cells(row_count, col_count).Address)
Dim i As Long
For i = 1 To col_count - 1
mainrange.AutoFilter field:=i, Criteria1:="="
Next i
Dim rg As Range
Set rg = mainrange.SpecialCells(xlCellTypeVisible)
mainrange.AutoFilter
rg.Rows.EntireRow.Hidden = True
rg.Rows(1).EntireRow.Hidden = False
End Sub
An if you turn off screenupdating etc. it should be pretty fast as well
picture of sheet where I want to take the values from.
I have a sheet where I want to iterate through one column. Column "E" in sheet3. There are many duplicates in this column. It must take the value, and insert it into sheet1 column "C". It is important that I do not have duplicates in sheet1. I have tried to solve this problem using dictionaries. But I cannot get it to work. Can someone help me?
This is the code i got for now. I am stuck and can not get further.
Sub test()
Const START_ROW = 11
Const MAX_ROW = 40
Const CODE_SHT1 = "C"
Const CODE_SHT4 = "E"
Const CVR_SHT4 = "C"
Const CVR_SHT3 = "C"
Const BROKER_SHT4 = "E"
' sheet 4 columns
'C - Employer CVR MD
'D - Employer name
'E - broker code
'F - Broker name
'? Employer CVR CER
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, wsNew As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionExceptionReport")
Set ws4 = wb.Sheets("MasterData")
Dim dict As Object, dictCVR As Object, dictBROKER As Object, sKey As String, ar As Variant
Dim sCVR As String, arCVR As Variant
Dim sBROKER As String, arBROKER As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set dictCVR = CreateObject("Scripting.Dictionary")
Set dictBROKER = CreateObject("Scripting.Dictionary")
' Get broker code + broker name from sheet 3 and insert into sheet one
iLastRow = ws4.Cells(Rows.count, BROKER_SHT4).End(xlUp).Row
For iRow = 18 To iLastRow
sKey = ws4.Cells(iRow, BROKER_SHT4)
If dictBROKER.exist(sKey) Then
dictBROKER(sKey) = dictBROKER(sKey) & ";" & iRow ' matched row on sheet 1
Else
dictBROKER(sKey) = iRow
End If
MsgBox (dict(sKey))
Next
End Sub
your code has to be amended from (at least):
a Next statament more (that by the end)
use of dict instead of dictBROKER
incorrect indentation (to have more chance to understand and control it)
so here it is after those changes
Sub Test()
Const START_ROW = 11
Const MAX_ROW = 40
Const BROKER_SHT4 = "E"
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, wsNew As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionExceptionReport")
Set ws4 = wb.Sheets("MasterData")
Dim dictBROKER As Object, dictCVR As Object, sKey As String, ar As Variant
Dim sCVR As String, arCVR As Variant
Dim sBROKER As String, arBROKER As Variant
Set dictBROKER = CreateObject("Scripting.Dictionary")
' Get broker code + broker name from sheet 3 and insert into sheet one
iLastRow = ws4.Cells(Rows.count, BROKER_SHT4).End(xlUp).Row
For iRow = 13 To iLastRow
sKey = ws4.Cells(iRow, BROKER_SHT4)
If dictBROKER.exists(sKey) Then
dictBROKER(sKey) = dictBROKER(sKey) & ";" & iRow ' matched row on sheet 1
Else
dictBROKER(sKey) = iRow
End If
MsgBox (dictBROKER(sKey))
Next
' add cvr records from sheet3 if any
sBROKER = ws4.Cells(iCopyRow, BROKER_SHT4)
If dictBROKER.exists(sBROKER) Then
arBROKER = Split(dictBROKER(sBROKER), ";")
For j = LBound(arBROKER) To UBound(arBROKER)
If j > 0 Then iTargetRow = iTargetRow + 1
' copy col C to D
iCopyRow = arBROKER(j)
Debug.Print sBROKER, j, iCopyRow
Next
Else
count = count + 1
End If
End Sub
Sub exportSheet2()
Const START_ROW = 11
Const MAX_ROW = 40
Const BROKER_SHT4 = "E"
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, wsNew As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Dim r As Long
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("sheet1")
Set ws3 = wb.Sheets("sheet3")
Set ws4 = wb.Sheets("sheet4")
Dim dict As Object, dictCVR As Object, sKey As String, ar As Variant
Dim sCVR As String, arCVR As Variant
Dim sBROKER As String, arBROKER As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set dictCVR = CreateObject("Scripting.Dictionary")
Set dictBROKER = CreateObject("Scripting.Dictionary")
' Get broker code + broker name from sheet 3 and insert into sheet one
iLastRow = ws4.Cells(Rows.count, BROKER_SHT4).End(xlUp).Row
r = 11
For iRow = 13 To iLastRow
sKey = ws4.Cells(iRow, BROKER_SHT4)
If dictBROKER.exists(sKey) Then
dictBROKER(sKey) = dictBROKER(sKey) & ";" & iRow ' matched row on sheet 1
Else
dictBROKER(sKey) = iRow
ws1.Range("E" & r) = sKey
ws1.Range("F" & r) = ws4.Cells(iRow, "F")
r = r + 1
End If
Next
code is copying data after every 5 seconds but i want it to copy only if bu8<>0 and if condition is not met then do nothing.
Here is the code
Sub UpdateData()
If Hour(Time) >= 3 And Minute(Time) >= 1 Then
Application.OnTime Now + TimeValue("0:0:5"), "UpdateData", False
Else
Application.OnTime Now + TimeValue("0:0:5"), "UpdateData"
CopyData
End If
End Sub
Sub CopyData()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim cRng As Range
Dim dCol As Long
Set sht1 = ThisWorkbook.Sheets("Sheet1")
Set sht2 = ThisWorkbook.Sheets("Sheet2")
Set cRng = sht1.Range("Bu1:bu8")
dCol = sht2.Cells(2, Columns.Count).End(xlToLeft).Column + 1
sht2.Range(Cells(2, dCol).Address, Cells(8, dCol + 1).Address) = cRng.Value
End Sub
You can do something like this:
Sub CopyData()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim cRng As Range, c As Range
Dim dCol As Long
Set sht1 = ThisWorkbook.Sheets("Sheet1")
Set c = sht1.Range("BU8")
If c.Value <> 0 and Len(c.Value)>0 Then
Set sht2 = ThisWorkbook.Sheets("Sheet2")
Set cRng = sht1.Range("Bu1:bu8")
sht2.Cells(2, Columns.Count).End(xlToLeft) _
.Offset(0, 1).Resize(8 ,1).value = cRng.Value
End If
End Sub
I have 10 worksheets.
I want to create a table for each. every table has a different amount of data, ive been using the following code for each, but i was wondering how to do it with a loop.
I would truly apreciate some help :)
Sub table()
Dim sht As Worksheet
Dim lastrow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set sht = Worksheets("m9")
Set StartCell = Range("A1")
lastrow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column
sht.Range(StartCell, sht.Cells(lastrow, LastColumn)).Select
Dim objTable As ListObject
Set objTable = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
End Sub
Tried the following, but with no luck
Sub loop_test()
Dim i As Integer
Dim ws_num As Integer
Dim starting_ws As Worksheet
Set starting_ws = ActiveSheet
ws_num = ThisWorkbook.Worksheets.Count
For i = 1 To ws_num
ThisWorkbook.Worksheets(i).Activate
'
Dim lastrow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set StartCell = Range("A1")
lastrow = Cells(Rows.Count, StartCell.Column).End(xlUp).Row
Range(StartCell, Cells(lastrow, LastColumn)).Select
Dim objTable As ListObject
Set objTable = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
Next
starting_ws.Activate
End Sub
You should avoid Activate and Select statements. The following will loop through all worksheets in the workbook and add a ListObject to each sheet. It will also test to see whether there is an already existing ListObject. If the existing ListObject overlaps with the range that you're going to add the table into to, it will convert it to a range before recreating the ListObject
Sub loop_test()
Dim ws As Worksheet
Dim StartCell As Range, TblRng As Range
Dim LastRow As Long, LastColumn As Long
Dim objTable As ListObject
For Each ws In ThisWorkbook.Sheets
Set objTable = Nothing
With ws
Set StartCell = .Range("A1")
LastRow = .Cells(.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = .Cells(StartCell.Row, .Columns.Count).End(xlToLeft).Column
Set TblRng = .Range(StartCell, .Cells(LastRow, LastColumn))
' Test if table exists on sheet
On Error Resume Next
Set objTable = .ListObjects(1)
On Error GoTo 0
' If table overlaps with TblRng - Convert to Range
If Not Intersect(objTable.Range, TblRng) Is Nothing Then
objTable.Unlist
End If
' Create Table
Set objTable = .ListObjects.Add(xlSrcRange, TblRng, , xlYes)
End With
Next ws
End Sub
Try this. As Zac says, steer clear of activating and selecting and include sheet references.
Sub loop_test()
Dim i As Long 'use Long, integer only goes up to c32k
Dim ws_num As Long
Dim starting_ws As Worksheet
Set starting_ws = ActiveSheet
ws_num = ThisWorkbook.Worksheets.Count
Dim lastrow As Long
Dim LastColumn As Long
Dim StartCell As Range, r As Range
Dim objTable As ListObject
For i = 1 To ws_num
With ThisWorkbook.Worksheets(i) 'don't need to activate
Set StartCell = .Range("A1")
lastrow = .Cells(.Rows.Count, StartCell.Column).End(xlUp).Row
Set r = .Range(StartCell, .Cells(lastrow, LastColumn))
Set objTable = .ListObjects.Add(xlSrcRange, r, , xlYes)
End With
Next i
End Sub