Please take a loot at this code:
I would like to export the my current view from Lotus Notes to Excel. However I am not able to. I have never worked with LotusScript before
Sub Click(Source As Button)
Dim session As New NotesSession
Dim wks As New NotesUIWorkspace
Dim db As NotesDatabase
Dim view As NotesView
Dim uiView As NotesUIView
Dim doc As NotesDocument
Dim column As NotesViewColumn
Dim row As Long,colcounter As Long,arrcnt As Long,arrcounter As Long, x As Long
Dim filename As String, currentvalue As String
Dim rowsatonce As Integer,cn As Integer
Dim xlApp As Variant, xlsheet As Variant,xlwb As Variant, xlrange As Variant, tempval As Variant
Dim DataArray
Dim VColumns List As String
Redim DataArray(0, 80) As String
'80 columns is our expected max number of columns in the view. It's dynamically recomputed below to actual (lower) number. Change if the number of columns is larger.
Set db=session.CurrentDatabase
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True 'Excel program is visible (to avoid errors and see what is happening)
Set xlwb=xlApp.Workbooks.Add
Set xlsheet =xlwb.Worksheets(1)
Set uiView = wks.CurrentView
Set view = db.GetView( uiView.ViewName ) ' get the view currently open in UI
arrcnt=0
row=1
colcounter=0
rowsatonce=20
Forall c In view.Columns
If c.isIcon<>True Then ' do not include icon columns
If c.Formula<>"""1""" And c.Formula<>"1" Then 'do not include columns which are used for counting docs (Total)
colcounter=colcounter+1
DataArray(row-1, colcounter-1) =c.Title
VColumns(Cstr(cn))=Cstr(cn)
End If
End If
cn=cn+1
End Forall
Redim Preserve DataArray(0, colcounter-1) As String
xlsheet.Range("A1").Resize(1, colcounter).Value = DataArray ' set column names
Redim DataArray(rowsatonce-1, colcounter-1) As String
row=2
x=0
Set doc = view.GetFirstDocument
While Not ( doc Is Nothing )
Forall col In VColumns
currentvalue=""
tempval= doc.ColumnValues(Val(col))
If Isarray(tempval) Then
Forall v In tempval
If currentvalue="" Then
currentvalue=v
Else
currentvalue=currentvalue+","+v
End If
End Forall
Else
currentvalue=tempval
End If
x=x+1
DataArray(arrcounter, x-1) =currentvalue
End Forall
x=0
row=row+1
arrcounter=arrcounter+1
If arrcounter/rowsatonce=arrcounter\rowsatonce And arrcounter<>0 Then
xlsheet.Range("A"+Cstr(arrcnt*rowsatonce+2)).Resize(rowsatonce, colcounter).Value = DataArray
arrcnt=arrcnt+1
arrcounter=0
Redim DataArray(rowsatonce-1, colcounter-1) As String
End If
Set doc = view.GetNextDocument (doc)
Wend
If arrcounter/rowsatonce<>arrcounter\rowsatonce And arrcounter>0 Then
' Redim Preserve DataArray(arrcounter, colcounter-1) As String
xlsheet.Range("A"+Cstr(arrcnt*rowsatonce+2)).Resize(arrcounter, colcounter).Value = DataArray
End If
Msgbox "Done"
End Sub
I am trying to create an action in Lotus Notes to export my current view into excel. It is giving me the error: "Object Variable not Set"
I suggest that you add at least a basic error handling.
add at the beginning a "on error goto handler"
and at the bottom something like
exit_point:
exit sub
handler:
print error$ & " in line " & cstr(erl)
resume exit_point
You might want to use my export script: from here
I haven't changed it for over 10 years, but it still works. As of Notes8 I prefer using the 'View Copy as Table' feature in Notes...
Regards
Daniel
Related
I have some vba code that 'attempts' to loop through an array of DAO recordsets. When running the loop, I get a runtime error 'Oject required' at rst.MoveFirst. It seems that rst is not properly initialized but I'm not sure how to fix it. Maybe looping through an array of recordsets isnt even possible in this way I have never tried it before. The code runs from a custom class module. There is a bunch more code in the module but most of the important stuff I post below. A couple things I tried:
Set rst to a new recordset instance manually:
Set rst = New DAO.Recordset
Declaring the array outside the loop:
Set recordsets = Array(rstRechenwerte, rstZwischenwerte, rstZutaten)
' Loop through each recordset and insert data into Excel file
For Each rst In recordsets
Setting rst to an open recordset right before rst.MoveFirst:
For Each rst In Array(rstRechenwerte, rstZwischenwerte, rstZutaten)
Set rst = rst.OpenRecordset()
rst.MoveFirst
The three recordsets in the array are properly initialized, set and are not Nothing. I had previously written the code for each of the three recordsets seperately and it works that way. I am aware that I need to change the variable name XLColumn, but thats not really an issue atm. Its probably something bassic but I couldn't figure it out for a while now so I thought I'd just ask.
I am using the following libraries for which references are properly set:
Visual Basic for Applications
Microsoft Access 16.0 Object Library
OLE Automation
Microsoft Office 16.0 Access database engine Object
Library
Microsoft Excel 16.0 Object Library
Microsoft Office 16.0 Object Library
My version of Access:
Microsoft® Access® für Microsoft 365 MSO (Version 2301 Build 16.0.16026.20002) 32 Bit
The code:
Option Compare Database
Option Explicit
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rsRes As DAO.Recordset 'rs of temp table (Output)
Dim rsZwi As DAO.Recordset 'rs of temp table (Zwischenwerte)
Dim rsRec As DAO.Recordset 'rs clone of subform Rechenwerte
Dim Recordset As Recordset
Dim rstRechenwerte As DAO.Recordset 'rs of tblRechenwerte
Dim rstZwischenwerte As DAO.Recordset 'rs of tblZwischenwerte
Dim rstZutaten As DAO.Recordset 'rs of tblZutaten
Dim RezeptID As Integer 'Current form active RezeptID
Dim RechengruppeID As Integer 'Current Form active RechengruppeID
Dim xlColumn As String 'Excel Column of Zutaten
Dim xlLastRow As Long 'Excel last row number after insertion
Dim xlColumn2 As String 'Excel Column one to the right of Zutaten
Dim k As Integer
Dim Export As Boolean 'Export the Excel File
Dim ExclExportPath As String 'Export location as string
Sub Calculate()
'***************************************************************************
'Purpose: Calculate a recipe based on Rechenwerte,
'save them temporarily and display them on a form.
'Inputs: None
'***************************************************************************
'***********************************************************************
' Preparations
'***********************************************************************
'Disable user input
Call mdlMiscFunctions.DisableKeyboardMouse(True)
'Clear temporary data tables for Results and Zwischenwerte
If Not rsRes.EOF Then Call ClearTableOnClose("tblTempResults")
If Not rsZwi.EOF Then Call ClearTableOnClose("tblTempZwischenwerte")
'Prevent prompt to save changes to excel
xlApp.DisplayAlerts = False
xlApp.Visible = False
'***********************************************************************
' Insert Data into Excel File
'***********************************************************************
Dim rst As DAO.Recordset
Dim xlCell As String
Dim xlFormula As String
Dim xlColumn As String
' Loop through each recordset and insert data into Excel file
For Each rst In Array(rstRechenwerte, rstZwischenwerte, rstZutaten)
rst.MoveFirst
If Not rst.EOF Then
Do Until rst.EOF
xlCell = rst!xlCell
xlSheet.Range(xlCell).Value = rst.Fields(1)
If rst.Fields.Count > 2 Then
xlFormula = rst!xlFormula
xlSheet.Range(xlCell).Offset(0, 1).Formula = xlFormula
xlSheet.Range(xlCell).Offset(0, 1).Value = xlSheet.Range(xlCell).Offset(0, 1).Value
Else
xlSheet.Range(xlCell).Offset(0, 1).Value = rst.Fields(2)
End If
rst.MoveNext
Loop
Else
Select Case rst.Name
Case "rstRechenwerte"
MsgBox "Error: Keine Rechenwerte vorhanden!", vbCritical
Case "rstZwischenwerte"
MsgBox "Error: Keine Zwischenwerte vorhanden!", vbCritical
Case "rstZutaten"
MsgBox "Error: Keine Zutaten vorhanden!", vbCritical
End Select
End If
Next rst
Class initialization is the following:
Private Sub Class_Initialize()
'***************************************************************************
'Purpose: Sub for initializing class variables
'Inputs: None
'***************************************************************************
'Values for variables 1 (Neccesary for recordsets)
RezeptID = Forms.frmCalcBatch.RezeptID 'RezeptID on current form
RechengruppeID = Forms.frmCalcBatch.RechengruppeID 'Rechengruppe on Current Form
'Initialize Objects
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add
Set xlSheet = xlWB.Sheets("Tabelle1") 'Set xlSheet to the first sheet in the workbook
Set rsRes = CurrentDb.OpenRecordset("tblTempResults", dbOpenDynaset)
Set rsZwi = CurrentDb.OpenRecordset("tblTempZwischenwerte", dbOpenDynaset)
Set rsRec = Forms.frmCalcBatch.frmSubRechenwerteBox.Form.Recordset.Clone 'rs clone of Rechenwerte subform
Set rstRechenwerte = CurrentDb.OpenRecordset("SELECT Rechenwert, WertBezeichnung, XLCell FROM tblRechenwerte WHERE RechengruppeID = " & RechengruppeID)
Set rstZwischenwerte = CurrentDb.OpenRecordset("SELECT ZWBezeichnung, XLFormula, XLCell FROM tblZwischenwerte WHERE RezeptID = " & RezeptID)
Set rstZutaten = CurrentDb.OpenRecordset("SELECT Zutat, XLFormula, XLCell FROM tblZutaten WHERE RezeptID = " & RezeptID)
'Values for Variables 2 (recordsets neccesary for variables)
xlColumn2 = Split(rstZutaten!xlCell, "1")(0) 'extract excel column denominator for Zutaten
xlColumn2 = Chr(Asc(xlColumn2) + 1) 'Move one column to the right using Asc (A->B etc.)
'Settings:
If Forms.frmCalcBatch.cbExport = True Then
Export = True
ExclExportPath = GetExportPath
Else
Export = False
ExclExportPath = ""
End If
End Sub
You cannot New up a DAO.Recordset, the code will not even compile.
To loop through an array of recordsets, each recordset must initialized before it is added to the array.
For example:
Dim r1 As DAO.Recordset, r2 As DAO.Recordset, r3 As DAO.Recordset
Set r1 = CurrentDb().OpenRecordset("YourTableOrQueryName")
Set r2 = CurrentDb().OpenRecordset("YourTableOrQueryName")
Set r3 = CurrentDb().OpenRecordset("YourTableOrQueryName")
Put the recordsets now in the array.
Dim arr As Variant
arr = Array(r1, r2, r3)
To loop, you need to use a For loop and either access the recordset from the array directly, or declare another recordset variable to hold the iterating recordset.
Through an iterator variable:
Dim r As DAO.Recordset, i As Integer
For i = LBound(arr) To UBound(arr)
Set r = arr(i)
If Not r.EOF Then
r.MoveFirst
Debug.Print r.RecordCount
End If
Next i
Access it directly from the array:
For i = LBound(arr) To UBound(arr)
If Not arr(i).EOF Then
arr(i).MoveFirst
Debug.Print arr(i).RecordCount
End If
Next i
Though I fail to see why you need to have 3 recordsets in memory at the same time. Personally, I would offload the work that needs to be done in the loop to a separate function and pass the recordset as parameter. The function itself would return a success/failed status, so you can take the appropriate action based on the result.
Another approach would be to store the source names in the array, and create the recordset on demand during the loop.
Hope this helps.
I'm trying to reduce redundancy in my macros but I'm struggling with getting an element from a jagged array and using it elsewhere.
The premise is a single workbook with many sheets being split by groups of sheet names into new documents that I can then send to the process owners so they only get their own data.
Previously I was selecting sheet names listed explicitly and pasting to a new document that was named explicitly, but I had to run 10 separate almost identical macros to do that and I have heard of select being a bad choice in many instances as well.
Below is my latest attempt, the first issue is at the printOut line I get a Type Mismatch.
Sub CopyOut()
Dim printOut, groupNames, Group1, groupArray() As Variant
Dim n, j As Long
Dim reNamed, fileName As String
Dim ws As Worksheet
Dim wb1, wb2 As Workbook
groupNames = Array("Group 1", "Group 2", "Group 3", "Group 4") 'other arrays left off for length
Group1 = Array("FA_1A Report", "FA_1A", "FA_2ACS Report", "FA_2ACS", "FA_2BCS Report", "FA_2BCS", "FANUCMED Report", "FANUCMED", "FA_RRTP1 Report", "FA_RRPT1")
groupArray = Array(groupNames, Group1)
For n = 1 To UBound(groupArray)
fileName = "CS Data Sheet" & " " & Format(Date, "mmmyy") & "-" & groupArray(n - n)(n - 1) & ".xlsm" 'concat file name string. this is not just tacked on the end of reName because i use it on it's own later
reNamed = "C:\Users\xx\Desktop\" & fileName 'concat save location string
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Add 'create a new workbook, wb2
wb2.SaveAs fileName:=reNamed, FileFormat:=xlOpenXMLWorkbookMacroEnabled 'save with that name and location
printOut = Join(Application.Index(groupArray, n, 0), ",")
wb1.Sheets(printOut).Copy Before:=Workbooks(fileName).Sheets(1) 'copy the sheets for the group and paste into the newly created document
Next
End Sub
If I nix printOut altogether and put in a specific worksheet name instead it does work for just that one sheet (of course) but I need it to copy multiple to each new document.
I have also tried:
For n = 1 To UBound(groupArray)
...
for j= LBound(groupArray(n)) To UBound(groupArray(n))
wb1.Sheets(groupArray(n)(j)).Copy Before:=Workbooks(fileName).Sheets(1)
next
next
to iterate through the subarray and copy a sheet at a time, but it gives subscript out of range. With this version I tried various methods of making the groupArray(n)(j) value into a string or into a "worksheet" type to set as a variable and use the variable in the sheets().copy, to no avail.
Any idea where I could be going wrong?
thanks so much
EDIT:
I got my above code working by wrapping it in split (was trying to use printOut as an array when it was only a string) and fixing the arguments of Index as below, however the resulting code still needs work, since if a sheet is missing it won't run.
printOut = Split(Join(Application.Index(groupArray(n), 1, 0), ","), ",")
In my experience, if you find yourself hard-coding values like sheet names, group names, and other data directly in your code it tends to become difficult to maintain. Adding more groups, or re-shuffling the sheets in each group becomes problematic. My recommendation is to create a (possibly hidden) worksheet that maps your worksheet names into groups. Then you have a small set of code that operates directly on that.
My example data is set up like this:
Next, in its own code module, I created a few methods to work directly with this group map data. The main idea here is to move the group map data into a memory-based array. While in general I rarely use module-level global variables, I have one in this example to illustrate how to work with the data by only reading it into the array once every time the macro is executed.
(These are Subs and Functions. For my own code, I likely would have created a VBA class to handle the data in an object-oriented way.)
So there is a Private Sub to get the data:
Option Explicit
Private groupData As Variant
Private Sub GetGroupData()
Const GROUP_WS_NAME As String = "GroupMap"
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(GROUP_WS_NAME)
Dim lastRow As Long
Dim lastCol As Long
With ws
'--- how many columns of groups?
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow = .UsedRange.Find("*", , , , xlByRows, xlPrevious).Row
groupData = .Range("A1").Resize(lastRow, lastCol).Value
End With
End Sub
Now it's easy to figure out how many groups there are:
Public Function NumberOfGroups() As Long
If IsEmpty(groupData) Then GetGroupData
NumberOfGroups = UBound(groupData, 2)
End Function
And how many items in a particular group:
Public Function NumberInGroup(ByVal groupNumber As Long)
If IsEmpty(groupData) Then GetGroupData
'--- count the number of array values that have data
Dim i As Long
For i = LBound(groupData, 1) To UBound(groupData, 1)
If groupData(i, groupNumber) = vbNullString Then
'--- we found the first empty cell in this array, we're done
Exit For
Else
NumberInGroup = NumberInGroup + 1
End If
Next i
'--- subtract one to discount the header value
NumberInGroup = NumberInGroup - 1
End Function
The easiest of all is getting the value of any group:
Public Function GetGroupValue(ByVal groupNumber As Long, _
ByVal groupIndex As Long) As Variant
If IsEmpty(groupData) Then GetGroupData
'--- always add one to the index to account for the header value
GetGroupValue = groupData(groupIndex + 1, groupNumber)
End Function
Notice the check for If IsEmpty(groupData) Then GetGroupData at the beginning of each method. This makes sure the groupData array is always loaded if necessary.
This example gives it a quick test (in a different code module):
Option Explicit
Sub test()
Dim totalGroups As Long
totalGroups = NumberOfGroups()
Dim i As Long
Dim j As Long
For i = 1 To totalGroups
Dim totalInGroup As Long
totalInGroup = NumberInGroup(i)
For j = 1 To totalInGroup
Debug.Print "group " & i & " = " & GetGroupValue(i, j)
Next j
Next i
End Sub
Here's the whole group data code module in a single block:
Option Explicit
Private groupData As Variant
Private Sub GetGroupData()
Const GROUP_WS_NAME As String = "GroupMap"
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(GROUP_WS_NAME)
Dim lastRow As Long
Dim lastCol As Long
With ws
'--- how many columns of groups?
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow = .UsedRange.Find("*", , , , xlByRows, xlPrevious).Row
groupData = .Range("A1").Resize(lastRow, lastCol).Value
End With
End Sub
Public Function NumberOfGroups() As Long
If IsEmpty(groupData) Then GetGroupData
NumberOfGroups = UBound(groupData, 2)
End Function
Public Function NumberInGroup(ByVal groupNumber As Long)
If IsEmpty(groupData) Then GetGroupData
'--- count the number of array values that have data
Dim i As Long
For i = LBound(groupData, 1) To UBound(groupData, 1)
If groupData(i, groupNumber) = vbNullString Then
'--- we found the first empty cell in this array, we're done
Exit For
Else
NumberInGroup = NumberInGroup + 1
End If
Next i
'--- subtract one to discount the header value
NumberInGroup = NumberInGroup - 1
End Function
Public Function GetGroupValue(ByVal groupNumber As Long, ByVal groupIndex As Long) As Variant
If IsEmpty(groupData) Then GetGroupData
'--- always add one to the index to account for the header value
GetGroupValue = groupData(groupIndex + 1, groupNumber)
End Function
If I got this right, you have one master workbook with n sheets and you want to group some of them, then create a new workbook for each group and paste in its assigned sheets.
I think an approach where you keep a "config" file in your master workbook for setting up groups and sheets, is more suitable rather than editing into code. Example:
The below code will create a file using the names from column A and copy all the sheets defined on their respective row.
Option Explicit
Sub CopyOut()
Dim groupArr() As Variant
Dim wb2 As Workbook
Dim lastRow As Long, lastCol As Long, highestNumOfSheets As Long, i As Long, j As Long, arrColumns As Long
Dim reNamed As String, fileName As String, configSheet As String
Dim removedSheet1 As Boolean
' Modify the sheet name here
configSheet = "config"
' Build an array from sheet defined groups
With ThisWorkbook.Worksheets(configSheet)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow
lastCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
If lastCol > highestNumOfSheets Then highestNumOfSheets = lastCol
Next i
groupArr = .Range(.Cells(2, 1), .Cells(lastRow, highestNumOfSheets)).Value2
End With
Application.ScreenUpdating = False
For i = LBound(groupArr) To UBound(groupArr)
fileName = "CS Data Sheet " & Format(Date, "mmmyy") & "-" & groupArr(i, 1) & ".xlsm"
reNamed = Environ("UserProfile") & "\Desktop\" & fileName
removedSheet1 = False ' Reset this on each new workbook created
Set wb2 = Workbooks.Add
' Pick all the sheet names for the current group
For j = 2 To UBound(groupArr, 2)
' Skip empty values from array (if it's the case) and skip missing sheets
If Trim(groupArr(i, j)) <> vbNullString And SheetExists(groupArr(i, j)) Then
ThisWorkbook.Worksheets(groupArr(i, j)).Copy Before:=wb2.Worksheets(1)
' Remove Sheet1 from the new Workbook
If removedSheet1 = False Then
With Application
.DisplayAlerts = False
wb2.Worksheets("Sheet1").Delete
removedSheet1 = True
.DisplayAlerts = True
End With
End If
End If
Next j
' Here you might need an error handler if you think you're going to run the macro multiple times in the same day
' If the file exists already this will throw an error
' A quick lazy way is to add time (including seconds) when you define the file name above
wb2.SaveAs fileName:=reNamed, FileFormat:=xlOpenXMLWorkbookMacroEnabled
wb2.Close
If Not wb2 Is Nothing Then Set wb2 = Nothing
Next i
Application.ScreenUpdating = True
End Sub
Function SheetExists(ByVal sheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0
If Not ws Is Nothing Then
SheetExists = True
Set ws = Nothing
End If
End Function
Of course it can be tweaked around, with error handling and other checks (depending on what you want to achieve entirely) but it should give you an alternative view of your code.
EDIT: Added a function to check if sheet exists.
Please assist. I have this code here and it works for first sheet however, does not execute in the 2nd sheet. I think i'm missing a sheet syntax. thanks.
Dim arrSheets As Variant, sht As Variant
arrSheets = Array("tl_1", "tl_2")
For Each sht In arrSheets
Sheets(sht).UsedRange.Offset(1).ClearContents
Next sht
My 2 cents: do not rely on worksheet names. Instead, work with their (Name) property as seen from the Visual Basic Editor. Note that you can give significant names yourself instead of the default Sheet1..N ones. This way, your code will survive modifications to the names as seen from Excel, in the tabs at the bottom.
Option Explicit
Public Sub DoTheClearThing()
Dim loopVariant As Variant
Dim loopWorksheet As Excel.Worksheet
Dim worksheetsToConsider As Variant
'Use the (Name) property, as seen from the Visual Basic Editor, of the worksheets you're interested in.
'The array below is not a string array; it is an array of worksheet objects.
worksheetsToConsider = Array(TL_1, TL_2)
'The For's variable must be a Variant; you can then Set it to a variable of the Worksheet type and enjoy Intellisense.
For Each loopVariant In worksheetsToConsider
Set loopWorksheet = loopVariant
loopWorksheet.UsedRange.Offset(1).ClearContents
Next
End Sub
Here's what the worksheets' (Name) properties look like in my test Excel workbook:
From within your workbook's code, you can directly interact with worksheet objects using their (Name) property. Avoid ThisWorkbook.Worksheets("tl_1").SomeMethod and directly go with TL_1.SomeMethod. By the way, a worksheet's (Name) property can be read by code using its CodeName property.
Option Explicit
'This will do something to your target sheets,
'just make sure your "something" is what you want
Dim N As Long
Dim wsName As String
'Optional if included
For N = 1 To ThisWorkbook.Sheets.Count
wsName = ThisWorkbook.Worksheets(N).Name
If wsName = "tl_1" or wsName = "tl_2" Then
ThisWorkbook.Worksheets(N).UsedRange.Offset(1).ClearContents
Else 'Do Nothing
End If
Next N
Note: This is very worksheet name dependent and users can change those if you are not the only user. You may want to CodeName your sheets (properties Explorer and change the Name) then pull the CodeName.
You can use an array to hold the sheets names but it seems like more trouble than its worth unless you are going to load the names into the array.
-WWC
Worksheet.UsedRange does not always return the correct address. Consider the results of the test below:
Test Used Range
Sub Test()
Application.ScreenUpdating = False
Dim cell As Range, target As Range
Debug.Print "Data Range", "|"; "UsedRange"
Debug.Print String(24, "_")
With Worksheets.Add
Set target = .Range("B2:D2")
target.Value = 1
Debug.Print target.Address, "|"; .UsedRange.Address
End With
With Worksheets.Add
.Range("A1:G10").Interior.Color = 65535
Set target = .Range("B2:D2")
target.Value = 1
Debug.Print target.Address, "|"; .UsedRange.Address
End With
End Sub
Clear Non-Headers
Sub ClearNonHeaderRows()
Dim arrSheets As Variant, sht As Variant
Dim cell As Range
arrSheets = Array("tl_1", "tl_2")
For Each sht In arrSheets
With Worksheets(sht).UsedRange
Set cell = .Find("*", .Cells(1, 1))
If Not cell Is Nothing Then
cell.Offset(1).Resize(.Cells.Rows.Count - cell.row + .Cells(1, 1).row).EntireRow.ClearContents
End If
End With
Next sht
End Sub
I have a problem with inserting data to the array. In the program I search all cells with "Data:" value. If this value appear I jump to the cell on the right and mark it. I want to collect all marked values (all of them are dates) in the array but with my code (enclosed below) I have an error. I have tried ReDim and setting an exact number of objects in the array. I would be grateful for a help.
Sub CheckData()
Dim FindIt As Range
Dim EndIt As Range
Dim StartAddress As String
With Range("A1:A100")
Set EndIt = .Cells(.Cells.Count)
End With
Set FindIt = Range("A1:A100").Find(what:="Data:", after:=EndIt)
If Not FindIt Is Nothing Then
StartAddress = FindIt.Address
End If
Dim Tabel() As Variant
Tabel = Array()
i = 0
Do Until FindIt Is Nothing
Set FindIt = Range("A1:A100").FindNext(after:=FindIt)
Data = FindIt.Address
Range(Data).Select
ActiveCell.Offset(0, 1).Select
ActiveCell.Interior.ColorIndex = 6
'Debug.Print ActiveCell.Value
Tabel(i) = ActiveCell.Value
i = i + 1
'Debug.Print i
If FindIt.Address = StartAddress Then
Exit Do
End If
Loop
End Sub
You never sized your array.
Dim Tabel() As Variant
Use ReDim to resize a dynamically-sized array.
ReDim Preserve Tabel(0 To UBound(Tabel)+1)
However that's a terribly inefficient thing to do in a loop (you're copying the same elements over and over and over and over again, at every single iteration).
Rule of thumb, if you don't know from the start how many elements you're going to need, it's probably best to use a Collection instead of an array.
Dim items As Collection
Set items = New Collection
'...
items.Add ActiveCell.Value
You could also use a for loop instead of a find (also using Mat's Mug idea about collections)
Sub CheckData1()
Dim ws As Worksheet
Dim searchRng As Range
Dim cell As Range
Dim tabel As Collection 'incorrectly spelt table?
Set ws = ActiveSheet
Set tabel = New Collection
Set searchRng = ws.Range("A1:A100")
For Each cell In searchRng.Cells
If cell.Value = "Data:" Then
tabel.Add cell.Offset(, 1)
cell.Offset(, 1).Interior.ColorIndex = 6 'If you still need it highlighted
End If
Next
End Sub
I´m trying to set a array with data from a MS Excel range.
My VBA Macro replaces the text from an array with text from another array.
It works fine with arrays, but now I´m trying to fill these arrays with data from a Excel file. I´m using range and I´ve tried thousands of ways of making itwork, unsuccessfuly. I´m not a VBA coder, so maybe I´m missing some basic concepts.... :|
Heres the code. Thanks in advance for any help!
Sub ReplacePT2ES()
Dim oSld As Slide
Dim oShp As Shape
Dim oTxtRng As TextRange
Dim oTmpRng As TextRange
Dim strWhatReplace As String, strReplaceText As String
Dim x As Long
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim rng As range
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("D:\DOCS\DiccionarioPT2ES.xlsx")
xlBook.Application.Visible = False
xlBook.Application.WindowState = xlMinimized
Dim findList As Variant
Dim replaceList As Variant
Set findList = range("A1:A3").Value
Set replaceList = range("B1:B3").Value
'-- works fine with array
'findList = Array("falha", "lei", "projeto", "falhas", "leis", "projetos", "falham", "os", "as", "gestor")
'replaceList = Array("falla", "ley", "proyecto", "fallas", "leyes", "proyectos", "fallan", "los", "las", "gerente")
'MsgBox "Iniciando!"
For x = findList.Count To replaceList.Count
' go during each slides
For Each oSld In ActivePresentation.Slides
' go during each shapes and textRanges
For Each oShp In oSld.Shapes
' replace in TextFrame
'If oShp.HasTextFrame And UBound(findList) And UBound(replaceList) > 0 Then
If oShp.HasTextFrame Then
Set oTxtRng = oShp.TextFrame.TextRange
Set oTmpRng = oTxtRng.Replace(FindWhat:=findList(x), Replacewhat:=replaceList(x), WholeWords:=True)
Do While Not oTmpRng Is Nothing
Set oTxtRng = oTxtRng.Characters(oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
Set oTmpRng = oTxtRng.Replace(FindWhat:=findList(x), Replacewhat:=replaceList(x), WholeWords:=True)
Loop
End If
Next oShp
Next oSld
Next x
xlBook.Close SaveChanges:=False
Set xlApp = Nothing
Set xlBook = Nothing
'MsgBox "Listo!"
End Sub
Finaly I found a solution: stop using Array and swith to Dictionary.
Here the code wich worked:
Set findList = range("A1:A10")
Dim MyDictionary As Object
Set MyDictionary = CreateObject("Scripting.Dictionary")
With MyDictionary
For Each RefElem In findList
If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then
.Add RefElem.Value, RefElem.Offset(0, 1).Value
End If
Next RefElem
End With
Moral of the history: use the right datatype for the job ;)
You can speed up your code significantly by:
Looping through a variant array rather than a range
Splitting your IF test into two parts (VBA doesn't shortcircuit so will evaluate both parts of an AND even if the first part is False).
code
Sub Recut()
Dim X
Dim MyDictionary As Object
Dim lngRow As Long
Set MyDictionary = CreateObject("Scripting.Dictionary")
X = Range("A1:B10").Value2
With MyDictionary
For lngRow = 1 To UBound(X)
If Len(X(lngRow, 1)) > 0 Then
If Not .Exists(X(lngRow, 1)) Then .Add X(lngRow, 1), X(lngRow, 2)
End If
Next
End With
End Sub