Script below currently stores an array and then compares it to an RTD updated array and outputs if there is a change. If there is no change then it will not log the change. Works great, but now I need an output log of the difference if a change occurs rather than output of a changed value in the updated array.
Code in Module 1
Public myArr()
Public Sub
PopulateMyArr()
myArr = Sheet4.Range("I6:I500").Value
End Sub
Code in This Workbook
Private Sub Workbook_Open()
PopulateMyArr
End Sub
Code in Sheet4(BA_Size)
Private Sub ToggleButton1_Click()
End Sub
Private Sub Worksheet_Calculate()
Dim keyCells As Range
On Error GoTo safeexit
Application.EnableEvents = False
Set keyCells = Me.Range("I6:J500")
If Worksheets("BA_Size").ToggleButton1.Value = True Then
Dim i As Integer
For i = 1 To UBound(myArr)
If keyCells(i, 1).Value <> myArr(i, 1) Then
nextrow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1
Sheet1.Cells(nextrow, "A").Value = Me.Cells(i + 5, "I").Value
End If
Next i
End If
safeexit:
PopulateMyArr
Application.EnableEvents = True
End Sub
Related
I have a user form with the following code. Basically what it does is If the user selects a title, and clicks commandButton2 which inserts the selected movie title into a titlebox and an array. Now i made another button commandButton3 which the user can select from the titlebox for which title to delete, but i am struggling deleting it from the array that i am building as well. Thanks in advance.
Public SelectedTitles As Variant, ArrCount As Long, EnableEvents As Boolean
Private Sub CommandButton1_Click()
'Done Button
Me.Hide
End Sub
Private Sub CommandButton2_Click()
'User has indicated they want to add the currently selected item to the list
If Not EnableEvents Then Exit Sub
If ArrCount = 0 Then 'First item, create the array
SelectedTitles = Array("")
Else
ReDim Preserve SelectedTitles(UBound(SelectedTitles) + 1) 'Next items, add one more space in the array
End If
'Add the selected title to the array
SelectedTitles(ArrCount) = ComboBox1.Value
ListBox1.AddItem (SelectedTitles(ArrCount))
'Increment the counter
ArrCount = ArrCount + 1
'Reset the checkbox and the combobox
EnableEvents = False
CommandButton2.Value = False
ComboBox1.Value = ""
EnableEvents = True
End Sub
Private Sub CommandButton3_Click()
For i = ListBox1.ListCount - 1 To 0 Step -1
If ListBox1.Selected(i) Then
ListBox1.RemoveItem i
If SelectedTitles() = i Then
SelectedTitles() = "n/a"
End If
ArrCount = ArrCount - 1
End If
Next i
EnableEvents = False
CommandButton3.Value = False
ComboBox1.Value = ""
EnableEvents = True
End Sub
Private Sub CommandButton4_Click()
ListBox1.Clear
Erase SelectedTitles
ArrCount = 0
EnableEvents = False
CommandButton4.Value = False
ComboBox1.Value = ""
EnableEvents = True
End Sub
Private Sub ListBox1_Click()
End Sub
Private Sub UserForm_Initialize()
EnableEvents = True
End Sub
Firt of all, using arrays in VBA can be a real pain. You might consider using ArrayLists instead, which are far more convenient to use. Check this:https://excelmacromastery.com/vba-arraylist/
Assuming your array was an arraylist you could just do you could just do :
For i = ListBox1.ListCount - 1 To 0 Step -1
If ListBox1.Selected(i) Then
ListBox1.RemoveItem i
SelectedTitles.RemoveAt i
End If
Next i
But if you wish to stick to your array you'll have to do something like this :
For i = ListBox1.ListCount - 1 To 0 Step -1
If ListBox1.Selected(i) Then
ListBox1.RemoveItem i
For j = 0 to Ubound(SelectedTitles)-1
If SelectedTitles(j) <> SelectedTitles (i) then
ReDim Preserve TempSelectedTitles(UBound(TempSelectedTitles) + 1)
TempSelectedTitles(j) = SelectedTitles(i)
end if
next J
SelectedTitles = TempSelectedTitle
End If
Next i
I didn't try this code but you got the idea, you will need to rebuild your array without including the selected value in you listbox
Have script that stores an array and if it changes it finds the difference. Now I need it to take that difference and check against if the adjacent cell is "John or Mary" and times the array value difference by: (If "John" = Array Value Diff. * PO#1) OR (If "Mary" = Array Value Diff. * PO#2). This is the final value I need written to Sheet 1 which right now is just the Array Value Diff. value.
Code in Module 1
Public myArr()
Public Sub PopulateMyArr()
myArr = Sheet4.Range("I6:I500").Value
End Sub
Code in This Workbook
Private Sub Workbook_Open()
PopulateMyArr
End Sub
Code in Sheet4
Private Sub ToggleButton1_Click()
End Sub
Private Sub Worksheet_Calculate()
Dim keyCells As Range
On Error GoTo safeexit
Application.EnableEvents = False
Set keyCells = Me.Range("I6:I500")
If Worksheets("BA_Size").ToggleButton1.Value = True Then
Dim i As Integer
For i = 1 To UBound(myArr)
If keyCells(i, 1).Value <> myArr(i, 1) Then
nextrow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1
Sheet1.Cells(nextrow, "A").Value = (keyCells(i, 1).Value - myArr(i, 1))
End If
Next i
End If
safeexit:
PopulateMyArr
Application.EnableEvents = True
End Sub
Untested:
Private Sub Worksheet_Calculate()
Dim keyCells As Range, i As Long, diff, cKey As Range
'exit if togglebutton not on
If Not Worksheets("BA_Size").ToggleButton1.Value Then Exit Sub
On Error GoTo safeexit
Application.EnableEvents = False
Set keyCells = Me.Range("I6:I500")
nextrow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1
For i = 1 To UBound(myArr)
Set cKey = keyCells(i, 1)
If cKey.Value <> myArr(i, 1) Then
diff = (cKey.Value - myArr(i, 1))
'check value in Col K
Select Case cKey.EntireRow.Columns("K").Value
Case "John": diff = diff * cKey.EntireRow.Columns("N").Value
Case "Mary": diff = diff * cKey.EntireRow.Columns("O").Value
Case Else: diff = 0
End Select
Sheet1.Cells(nextrow, "A").Value = diff
nextrow = nextrow + 1
End If
Next i
safeexit:
PopulateMyArr
Application.EnableEvents = True
End Sub
Assigning word document lines of text to an array to then print into an excel column. I want to print each item in array to it's own cell.
Currently, all the items are storying correctly into the array, but it's only printing the first item over and over Action
Code:
Option Explicit
Sub ParaCopy()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open("J:\Data Dictionary.docx", ReadOnly:=True)
Dim wPara As Word.Paragraph
Dim arr() As Variant
Dim i As Long
i = 0
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
ReDim Preserve arr(i)
arr(i) = wPara.Range
End If
i = i + 1
Next wPara
For i = LBound(arr) To UBound(arr)
[a1].Resize(UBound(arr) + 1) = arr
Next i
End Sub
EDIT: Need to separate each block of text separated by a space (outlined in blue) to this
Create a 2D array with one column and load that:
Option Explicit
Sub ParaCopy()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open("J:\Data Dictionary.docx", ReadOnly:=True)
Dim wPara As Word.Paragraph
Dim arr() As Variant
ReDim arr(1 To wDoc.Paragraphs.Count, 1 To 1)
Dim i As Long
i = 1
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
arr(i, 1) = wPara.Range
i = i + 1
End If
Next wPara
[a1].Resize(UBound(arr) + 1) = arr
End Sub
Copy Word Paragraphs to Excel Cells Using an Array
The number of rows of the array is wDoc.Paragraphs.Count which may differ from r (the 'actual count') hence you have to use r with Resize, and not wDoc.Paragraphs.Count or UBound(Data, 1).
Don't forget to Close the Document and Quit the App.
The first solution is early-bound and needs the library reference. When using it, just use
Set wApp = New Word.Application.
The second solution is late-bound and doesn't need the library reference. Also, it has been 'stripped off' the document and application variables (not necessary, you can declare them As Object).
Option Explicit
' e.g. Tools>References>Microsoft Word 16.0 Object Library
Sub ParaCopy()
Const FilePath As String = "J:\Data Dictionary.docx"
Dim wApp As Word.Application: Set wApp = Set wApp = New Word.Application
Dim wDoc As Word.Document: Set wDoc = wApp.Documents.Open(FilePath, , True)
Dim Data As Variant: ReDim Data(1 To wDoc.Paragraphs.Count, 1 To 1)
Dim wPara As Word.Paragraph
Dim r As Long
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
r = r + 1
Data(r, 1) = wPara.Range
End If
Next wPara
wDoc.Close False
wApp.Quit
[a1].Resize(r) = Data
End Sub
Sub ParaCopyNoReference()
Const FilePath As String = "J:\Data Dictionary.docx"
With CreateObject("Word.Application")
With .Documents.Open(FilePath, , True)
Dim Data As Variant: ReDim Data(1 To .Paragraphs.Count, 1 To 1)
Dim wPara As Object
Dim r As Long
For Each wPara In .Paragraphs
If wPara.Range.Words.Count > 1 Then
r = r + 1
Data(r, 1) = wPara.Range
End If
Next wPara
.Close False
End With
.Quit
End With
[a1].Resize(r) = Data
End Sub
The code below removes values and indexes from array. I am wondering on how to stop the code once the array index gets too less than 0. The code currently breaks at this point, and I am looking at ways on trying to handle this.
Dim ws As Worksheet
Dim cmbbox() As Variant 'or String
Private Sub btnUndo_Click()
Dim idx As Integer
'idx = UBound(cmbbox) - 1
If Not Len(Join(cmbbox, "")) = 0 Then 'if your array is not empty remove the last value from it
ReDim Preserve cmbbox(UBound(cmbbox) - 1)
'cmbbox(0) = cbDepartmentNotes.Value
'MsgBox (idx)
Else 'if your array is empty redim your array and add value from combobox
MsgBox ("Please select your note")
'ReDim Preserve cmbbox(UBound(cmbbox) + 1)
'cmbbox(UBound(cmbbox)) = cbDepartmentNotes.Value
End If
'MsgBox "You selected Item : " & cmbbox(UBound(cmbbox))
'ListBox1.List = cmbbox
txtDepartmentNoteTemplate.Text = Join(cmbbox, ", ")
End Sub
Private Sub UserForm_Initialize()
Dim rngDepartment As Range
Set ws = Worksheets("Sheet1")
'Populate Department combo box.
For Each rngDepartment In ws.Range("Departments")
cbDepartment.AddItem rngDepartment.Value
Next rngDepartment
UserForm1.cbDepartmentNotes.Enabled = False
UserForm1.txtDepartmentNoteTemplate.Enabled = False
End Sub
Private Sub CommandButton1_Click() ' adds value to array and displays them in text box
If Len(Join(cmbbox, "")) = 0 Then 'if your array is empty add the first value from combobox to it
ReDim cmbbox(0)
cmbbox(0) = cbDepartmentNotes.Value
Else 'if your array is not empty redim your array and add value from combobox
ReDim Preserve cmbbox(UBound(cmbbox) + 1)
cmbbox(UBound(cmbbox)) = cbDepartmentNotes.Value
End If
'MsgBox "You selected Item : " & cmbbox(UBound(cmbbox))
'ListBox1.List = cmbbox
txtDepartmentNoteTemplate.Text = Join(cmbbox, ", ")
End Sub
Private Sub cbDepartment_Change() 'combo box value display function
displayNote
End Sub
Private Sub cbDepartmentNotes_Change()
txtDepartmentNoteTemplate.Enabled = True
End Sub
Function displayNote() As String
Dim rngDepartmentNote As Range
Dim x As String
Set ws = Worksheets("Sheet1")
If cbDepartment.Value = "IT" Then
cbDepartmentNotes.Clear
For Each rngDepartmentNote In ws.Range(Cells(3, "A"), Cells(3, "A").End(xlDown))
cbDepartmentNotes.Enabled = True
cbDepartmentNotes.AddItem rngDepartmentNote.Value
x = cbDepartmentNotes.Value
displayNote = x
Next rngDepartmentNote
ElseIf cbDepartment.Value = "PST" Then
cbDepartmentNotes.Clear
For Each rngDepartmentNote In ws.Range(Cells(3, "B"), Cells(3, "B").End(xlDown))
cbDepartmentNotes.Enabled = True
cbDepartmentNotes.AddItem rngDepartmentNote.Value
txtDepartmentNoteTemplate.Enabled = True
x = cbDepartmentNotes.Value
displayNote = x
Next rngDepartmentNote
End If
End Function
I'm running into an odd issue. I have 2 Userform, at first Userform2 was inside Userform1, but I wasn't able to make it run. After that I made that a Sub in my Module call Userform2 after other once Userform1 is done.
The problem is the Userform2 is a Multiselect Listbox, and I save each selection in an array and when the Userform2 unloads the array seems to be empty.
I have checked for hours many errors like: I have no explicit option on, but the code is pretty short and I have looked for the array within my code and it only appears on the exact parts I wanted it to be.
Neither the public array as variant was a problem, because it is outside the Userform and in the original Module.
I'm from Chile so some variables have names in Spanish and my English might not be so good, I'll do my best to explain my self.
Here is the code:
Global lenarrv
Global Arrver
Global BoxPMData
Global anno
Global PMDATAarray
Global LenPMDArray
Public varfamilia As Variant
Public pampm As Variant
Sub AbrirMaestro(ByVal anno As Variant)
Application.ScreenUpdating = False
UserForm1.Show
UserForm2.Show
Dim Arrver() As Variant
Dim lenarrv As Long
contentosrcontento = 1
lenarrv = UBound(pampm)
For tt = 0 To lenarrv - 1
ReDim Arrver(contentosrcontento)
Arrver(contentosrcontento) = pampm(tt)
contentosrcontento = contentosrcontento + 1
Next tt
lenarrv = UBound(Arrver)
Inputbox_PMDATA anno
End Sub
Here comes the Userforms:
Private Sub UserForm_Activate()
Me.StartUpPosition = 1
Me.Left = Application.Left + Application.Width - Me.Width - 400
End Sub
Private Sub UserForm_Initialize()
Dim listaitems As Variant
Workbooks("MAESTROS.xlsx").Activate
numerofilas = Workbooks("MAESTROS.xlsx").Sheets("VERTICALES").Cells(2, 1).End(xlDown).Row
listaitems = Workbooks("MAESTROS.xlsx").Sheets("VERTICALES").Range("A2:A" & numerofilas)
listaitems = Application.WorksheetFunction.Transpose(listaitems)
For h = 1 To numerofilas - 1
ListBox1.AddItem listaitems(h)
Next h
Workbooks("MAESTROS.xlsx").Close False
End Sub
Public Sub CommandButton1_Click()
Dim i As Integer
Dim count As Integer
count = 1
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
ReDim pampm(count)
pampm(i) = ListBox1.List(i)
count = count + 1
End If
Next i
Unload UserForm2
End Sub
Here is UserForm1 :
Private Sub UserForm_Activate()
Me.StartUpPosition = 1
Me.Left = Application.Left + Application.Width - Me.Width - 400
End Sub
Private Sub UserForm_Initialize()
Dim ListItems As Variant
MsgBox ("Elegir el archivo MAESTRO")
Master = Application.GetOpenFilename(MultiSelect:=False)
isBool = VarType(Master) = vbBoolean
If isBool Then If Not Master Then End
Application.ScreenUpdating = False
Set abrirlibro = Workbooks.Open(Master)
numrows = abrirlibro.Worksheets("MASTERFAMILIA").Cells(2, 2).End(xlDown).Row
ListItems = abrirlibro.Worksheets("MASTERFAMILIA").Range("B2:B" & numrows)
ListItems = Application.WorksheetFunction.Transpose(ListItems)
For i = 1 To numrows - 1
ComboBox1.AddItem ListItems(i) ' populate the listbox
Next i
'abrirlibro.Close False
'Set abrirlibro = Nothing
End Sub
Public Sub CommandButton1_Click()
varfamilia = ComboBox1.value
Unload UserForm1
End Sub
I can't past the full code since there are more than 2k lines..
Any help is welcome.
Greetings!
you have to change
Public pampm As Variant
to
Public pampm() As Variant
and
ReDim pampm(count)
to
ReDim Preserve pampm(count)