I have written some code that populates a preformatted worksheet in an another workbook, from another preformatted worksheet. They include merged cells and all other things nasty, and for whatever reason cannot be changed.
So, I have written the following
Sub test()
Dim wbkCurrent As Workbook
'Dim wbk3Mth As Workbook
Dim wbk6Mth As Workbook
Set wbkCurrent = ThisWorkbook
Set wbk6Mth = Workbooks.Open("C:\newbook.xlsm")
newbook.Sheets("Mon 1").Activate
Call assignArrays
End Sub
Sub assignArrays
Call moveValues(32, 3, 7, 8)
Call moveValues(32, 5, 23, 6)
Call moveValues(32, 65, 15, 8)
Call moveValues(32, 56, 31, 5)
Call moveValues(32, 57, 31, 11)
Call moveValues(32, 15, 39, 4)
Call moveValues(32, 16, 39, 5)
Call moveValues(32, 17, 39, 6)
Call moveValues(32, 18, 39, 7)
Call moveValues(32, 30, 39, 10)
Call moveValues(32, 31, 39, 11)
Call moveValues(32, 32, 39, 12)
Call moveValues(32, 33, 39, 13)
Call moveValues(32, 7, 7, 21)
Call moveValues(32, 9, 23, 19)
Call moveValues(32, 66, 15, 21)
Call moveValues(32, 59, 31, 18)
Call moveValues(32, 60, 31, 24)
Call moveValues(32, 20, 39, 17)
Call moveValues(32, 21, 39, 18)
Call moveValues(32, 22, 39, 19)
Call moveValues(32, 23, 39, 20)
Call moveValues(32, 35, 39, 23)
Call moveValues(32, 36, 39, 24)
Call moveValues(32, 37, 39, 25)
Call moveValues(32, 38, 39, 26)
Call moveValues(32, 11, 7, 34)
Call moveValues(32, 13, 23, 32)
Call moveValues(32, 67, 15, 34)
Call moveValues(32, 62, 31, 31)
Call moveValues(32, 63, 31, 37)
Call moveValues(32, 25, 39, 30)
Call moveValues(32, 26, 39, 31)
Call moveValues(32, 27, 39, 32)
Call moveValues(32, 28, 39, 33)
Call moveValues(32, 40, 39, 36)
Call moveValues(32, 41, 39, 37)
Call moveValues(32, 42, 39, 38)
Call moveValues(32, 43, 39, 39)
End Sub
Sub moveValues(tRow, tCol, rRow, rCol)
'trow is row in this workbook, tcol is column in this workbook, rRow & rCol are the same for the other workbook
ActiveSheet.Cells(rRow, rCol).Value = ThisWorkbook.Sheets("Results").Cells(tRow, tCol).Value
tRow = tRow + 1
rRow = rRow + 1
ActiveSheet.Cells(rRow, rCol).Value = ThisWorkbook.Sheets("Results").Cells(tRow, tCol).Value
tRow = tRow + 1
rRow = rRow + 1
ActiveSheet.Cells(rRow, rCol).Value = ThisWorkbook.Sheets("Results").Cells(tRow, tCol).Value
tRow = tRow + 1
rRow = rRow + 1
ActiveSheet.Cells(rRow, rCol).Value = ThisWorkbook.Sheets("Results").Cells(tRow, tCol).Value
tRow = tRow + 1
rRow = rRow + 1
ActiveSheet.Cells(rRow, rCol).Value = ThisWorkbook.Sheets("Results").Cells(tRow, tCol).Value
tRow = tRow + 1
rRow = rRow + 1
ActiveSheet.Cells(rRow, rCol).Value = ThisWorkbook.Sheets("Results").Cells(tRow, tCol).Value
End Sub
This works fine, and writes all the data out. Problem is, I need this to run starting where
trow = 2,12,22,32,42,52
Now I could write this all out manually, but it would mean that going in and changing it later would be a nightmare. So, I had the idea of using a = 2,12,22,32 etc and then having
call moveValues(a, 3, 7, 8)
However this means a bumps up a digit through the moveValues subroutine, and needs resetting each time.
I have one idea to solve this using arrays, but that has its own issues.
I replaced the module assignArrays with
Sub assignArrays()
'row in this workbook
Dim array1(5)
array1(5) = Array(2, 12, 22, 32, 42, 52)
'E
Dim array2(12)
array2(12) = Array(3, 5, 65, 56, 57, 15, 16, 17, 18, 30, 31, 32, 33)
'U
Dim array2_1(12)
array2_1(12) = Array(7, 9, 66, 59, 60, 20, 21, 22, 23, 35, 36, 37, 38)
'R
Dim array2_2(12)
array2_2(12) = Array(11, 13, 67, 62, 63, 25, 26, 27, 28, 40, 41, 42, 43)
'row in report
Dim array3(12)
array3(12) = Array(7, 23, 15, 31, 31, 39, 39, 39, 39, 39, 39, 39, 39) 'constant in each array 1
'column in report
Dim array4(12)
array4(12) = Array(8, 6, 8, 5, 11, 4, 5, 6, 7, 10, 11, 12, 13) '+13 for each third
Dim v1, v2, v3, v4 As Integer
For a = 0 To 5
v1 = array1(a)
For b = 0 To 12
v3 = array3(b)
For c = 0 To 12
v4 = array4(c)
For d = 0 To 12
v2 = array2(d)
Call moveValues(v1, v2, v3, v4)
Next d
Next c
For c = 0 To 12
v4 = array4(c) + 13
For d = 0 To 12
v2 = array2(d)
Call moveValues(v1, v2, v3, v4)
Next d
Next c
For c = 0 To 12
v4 = array4(c) + 26
For d = 0 To 12
v2 = array2(d)
Call moveValues(v1, v2, v3, v4)
Next d
Next c
Next b
Next a
End Sub
This dies with a 1004 error on the first line of moveValues. Any ideas to fix either solution?
You are not dealing with arrays properly.
Dim array1(5) 'Array with 5 dimension
array1(5) = Array(2, 12, 22, 32, 42, 52) 'Write all this content to the fifth position
The proper way to do that is:
Dim array1(5) As Integer
array1(0) = 2
array1(1) = 12
array1(2) = 22
array1(3) = 32
array1(4) = 42
array1(5) = 52
If you want to rely on one line, you can do:
Dim array1
array1 = Array(2, 12, 22, 32, 42, 52) 'In this case, it starts from 0 -> pretty unconventional (bear in mind that the array above is dimensioned from 1)
---- UPDATE
What your code delivers:
Dim array1(5)
array1(5) = Array(2, 12, 22, 32, 42, 52)
Dim test1 As Integer: test1 = array1(0) '-> 0
Dim test2 As Integer: test2 = array1(1) '-> 0
Dim test3 As Integer: test3 = array1(2) '-> 0
Dim test4 As Integer: test4 = array1(3) '-> 0
Dim test5 As Integer: test5 = array1(4) '-> 0
Dim test6 As Integer: test6 = array1(5) 'ERROR
What my code delivers:
Dim array1
array1 = Array(2, 12, 22, 32, 42, 52)
Dim test1 As Integer: test1 = array1(0) '-> 2
Dim test2 As Integer: test2 = array1(1) '-> 12
Dim test3 As Integer: test3 = array1(2) '-> 22
Dim test4 As Integer: test4 = array1(3) '-> 32
Dim test5 As Integer: test5 = array1(4) '-> 42
Dim test6 As Integer: test6 = array1(5) '-> 52
Related
there I have an excel VBA code that retrieves its records from an external file by month and set it according to the column heading.
However, i have an error in of application-defined or object-defined error in of the line .Range("A6").Resize(n, 23) = b
does anyone know why
code:
Sub zz()
Dim arr, c, b(), n&
Application.ScreenUpdating = False
Worksheets("Sheet2").Range("A6").AutoFilter
Workbooks.Open "C:\Users\sophia.tan\Desktop\MasterPlanData.xlsx", 0, 1
arr = Sheets("Excel").UsedRange
ActiveWorkbook.Close 0
c = Array(0, 2, 13, 14, 7, 8, 11, 1, 9, 10, 16, 17, 20, 22, 15, 30, 27, 28, 29, 3, 4, 30)
d = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23)
ReDim b(1 To UBound(arr), 1 To 23)
For i = 2 To UBound(arr)
If arr(i, 12) >= DateSerial(Year:=2017, Month:=11, Day:=1) And arr(i, 12) <= DateSerial(Year:=2017, Month:=11, Day:=31) Then
n = n + 1
For j = 1 To UBound(c)
b(n, d(j)) = arr(i, c(j))
Next
End If
Next
With Worksheets("Sheet2")
.Range("A6:T" & Rows.Count).CurrentRegion.AutoFilter field:=1, Criteria1:="<>OFM"
.Range("A6:T" & Rows.Count).CurrentRegion.SpecialCells(xlCellTypeVisible).AutoFilter field:=13, Criteria1:="<>Collar & Cuff"
.Range("A6:T" & Rows.Count).CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.Range("A6").Resize(n, 23) = b
.Range("A6").CurrentRegion.Sort key1:=Range("G6"), order1:=xlAscending, Header:=xlYes
.Range("A6").Select
End With
Application.ScreenUpdating = 1
End Sub
Your determination on n is subjective to the If statement. However, any unfilled values in the 'rows' of b will be vbnullstrings and will produce truly blank cells.
.Range("A6").Resize(ubound(b, 1), ubound(b, 2)) = b
Alternately,
For i = 2 To UBound(arr)
If arr(i, 12) >= DateSerial(Year:=2017, Month:=11, Day:=1) And arr(i, 12) <= DateSerial(Year:=2017, Month:=11, Day:=31) Then
n = n + 1
For j = 1 To UBound(c)
b(n, d(j)) = arr(i, c(j))
Next
End If
Next
b = application.transpose(b)
redim preserve b(lbound(b, 1) to ubound(b, 1), lbound(b, 2) to n)
b = application.transpose(b)
.Range("A6").Resize(n, 23) = b
You can only adjust the last rank of an array with ReDim when using the preserve parameter.
Try
.Range("A6").Resize(n, 23).Value = b
I have been doing a little bit of research if its possible to highlight cells which have been manually amended (by typing in the information) as oppose via marco. What i really came across was track changes which might not apply in this situation
Scenario
I have a macro which runs each time certain cells are double clicked. When a cell is double clicked a timestamp is provided, which is perfectly fine.
Problem
I am trying to aviod the situation were a user tries to amend the time stamp manually, or any of that information in that relevant cell. I am trying to aviod using the methdology of locking cells once update.
Solution to be achieved.
Is it possible that if a cell has been manually updated by user that its highlighted. However if it has been update through the use of the macro thats ok.
Code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.EnableEvents = False
With Target
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
.Value2 = "Prepared By" & " " & Environ("Username")
.Value2 = .Value2 & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
End Select
End If
End With
The simplest solution to this would just to be enforce any changes to your selected cells with the change event. I assume the double click aspect is to make it more user friendly for the input so we won't remove that, rather duplicate it:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Target
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
.Value2 = "Prepared By" & " " & Environ("Username") & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
End Select
End If
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
If Target.Cells.Count = 1 Then
With Target
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
.Value2 = "Prepared By" & " " & Environ("Username") & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
End Select
End If
End With
Else
For Each cell In Target.Cells
With cell
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
.Value2 = "Prepared By" & " " & Environ("Username") & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
End Select
End If
End With
Next cell
End If
End Sub
I am currently working with two pieces of vba code. I am trying to marry them together to achieve the below purpose.
First code
I have code that allows users to double click on a cell and then it time stamps the cell, and subsequently locks the relevant cell. Which works fine. However is some instances the user will have to type in NA and different piece of code will run ( Second code).
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.EnableEvents = False
With Target
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
Sheets("Sheet3").Protect Password:="Test", userinterfaceonly:=True
.Value2 = "Prepared By" & " " & Environ("Username")
.Value2 = .Value2 & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
.Locked = True
End Select
End If
End With
End Sub
Second Code when user Types NA
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'// Check if the target row number is in our array:
Select Case Target.Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
' Do Something
If CStr(Target.Value) Like "*NA*" Then
Target.Value = "Not applicable" & " " & Environ("Username") & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
End If
Case Else
' Do nothing
Exit Sub
End Select
End Sub
Problem to Overcome
Once the user double clicks on a the cell and it locks , there are not able to later change that cell to NA. NA should be the only value that the user should be able to type once cell is locked.
Question
Is there a way that i can allow the user to type in NA only once the cell is locked. Therefore user only has two options to type na or Double click
Obviously you can't type anything until a cell is locked. Add data validation to allow "NA" only instead of locking the cell. Something like this:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.EnableEvents = False
With Target
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
.Value2 = "Prepared By" & " " & Environ("Username") & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
With .Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="NA"
.IgnoreBlank = False
.InCellDropdown = False
.ErrorTitle = "Invalid input"
.ErrorMessage = "NA available only"
.ShowError = True
End With
End Select
End If
End With
Application.EnableEvents = True
End Sub
This method assumes that the worksheet isn't protected at all.
I have a 2d array holding values like the following:
array - JK(K, NC)
"K" Stores Total No of Items
"NC" Stores Items
I need to remove the duplicates From "NC"
and also update "K" (i.e the total items) after removing the duplicates.
4 - 5, 6, 7, 5
6 - 7, 6, 9, 10, 11, 7
4 - 8, 7, 15, 8
9 - 12, 15, 16, 12, 17, 18, 19, 20, 16
3 - 26, 27, 26
3 - 20, 19, 20
6 - 21, 33, 33, 34, 35, 21
8 - 19, 33, 34, 18, 38, 39, 40, 34
5 - 39, 40, 38, 43, 40
6 - 41, 44, 44, 45, 46, 41
3 - 20, 19, 20
6 - 21, 33, 33, 34, 35, 21
8 - 19, 33, 34, 18, 38, 39, 40, 34
Here is a Solution based on the Entries and Code from #tigeravatar and #Jeeped with you could have find here on Stack overflow, so a big thanks to this guys.
Removing Duplicate values from a string in Visual Basic
and
Multidimensional Arrays with For Loops VBA
Sub Test()
Dim strArray(8, 1) As String
Dim newString As String
strArray(0, 0) = "4"
strArray(0, 1) = "5 6 7 5"
strArray(1, 0) = "6"
strArray(1, 1) = "7 6 9 10 11 7"
strArray(2, 0) = "4"
strArray(2, 1) = "8 7 15 8"
strArray(3, 0) = "9"
strArray(3, 1) = "12 15 16 12 17 18 19 20 16"
strArray(4, 0) = "4"
strArray(4, 1) = "5 6 7 5"
strArray(5, 0) = "6"
strArray(5, 1) = "7 6 9 10 11 7"
strArray(6, 0) = "9"
strArray(6, 1) = "12 15 16 12 17 18 19 20 16"
For i = 0 To UBound(strArray, 1)
newString = DeDupeString(strArray(i, 1), " ")
strArray(i, 0) = UBound(Split(newString, " ")) + 1
strArray(i, 1) = newString
Next i
End Sub
Function DeDupeString(ByVal sInput As String, Optional ByVal sDelimiter As String = ",") As String
Dim varSection As Variant
Dim sTemp As String
varSection = Split(sInput, sDelimiter)
For Each varSection In Split(sInput, sDelimiter)
If InStr(1, sDelimiter & sTemp & sDelimiter, sDelimiter & varSection & sDelimiter, vbTextCompare) = 0 Then
sTemp = sTemp & sDelimiter & varSection
End If
Next varSection
DeDupeString = Mid(sTemp, Len(sDelimiter) + 1)
End Function
You could use a function, something like this
Function RemoveDupes(strInput As String) As Variant()
' Uses Microsoft Scripting Runtime referece
Dim arrSplit() As String
Dim lngCounter As Long
Dim dicDupeCheck As New Scripting.dictionary
arrSplit = Split(strInput, Chr(32))
For lngCounter = 0 To UBound(arrSplit) - 1
If Not dicDupeCheck.Exists(arrSplit(lngCounter)) Then
dicDupeCheck.Add arrSplit(lngCounter), arrSplit(lngCounter)
End If
Next lngCounter
RemoveDupes = Array(dicDupeCheck.Count, Join(dicDupeCheck.Items(), " "))
Erase arrSplit
End Function
This will then be used as follows
RemoveDupes("12 15 16 12 17 18 19 20 16")(0) will give the count, and RemoveDupes("12 15 16 12 17 18 19 20 16")(1) will give the non-dupe output.
Or set an array to removedupes and use that, so arr=RemoveDupes("12 15 16 12 17 18 19 20 16") then OriginalArray(x)=arr(0) & " - " & arr(1)
The below code of mine works well the issue I have is that my ranges have now expanded and i need a more efficient way to approach it.
The Code updates my Date worksheet sheet when the below ranges have been updated and file also saved ( both conditions need to be met) . Any advice?
Sheet3.Range D ( 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65)
Sheet3.Range E ( 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65)
'set as public variables to remain saved while workbook is open
Public val1, val2, val3, val4, Val5
Private Sub Workbook_Open()
'set the variables when the workbook is opened
Call SetValues
End Sub
Private Sub SetValues()
'save the values to be checked later
val1 = Sheets("Sheet3").Range("D20").Value
val2 = Sheets("Sheet3").Range("D24").Value
val3 = Sheets("Sheet3").Range("D25").Value
val4 = Sheets("Sheet3").Range("D27").Value
Val5 = Sheets("Sheet3").Range("D28").Value
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet, wsDates As Worksheet
Dim endRow As Long, updateRow As Long, x As Long
Dim checkDate
Set ws = ThisWorkbook.Sheets("Sheet3")
Set wsDates = ThisWorkbook.Sheets("Dates")
'if the values have been changed
If _
val1 <> ws.Range("D20").Value Or _
val2 <> ws.Range("D24").Value Or _
val3 <> ws.Range("D25").Value Or _
val4 <> ws.Range("D27").Value Or _
Val5 <> ws.Range("D28").Value Then
'reset the values to avoid multiple updates
Call SetValues
'set the range of values to check
endRow = wsDates.Cells(wsDates.Rows.Count, 1).End(xlUp).Row
'check to see if an entry was found the same week
For x = 1 To endRow
checkDate = wsDates.Cells(x, 2).Value
If checkDate >= (Date - Weekday(Date, vbSunday) + 1) And checkDate <= (Date - Weekday(Date, vbSaturday) + 1 + 7) Then
updateRow = x
Exit For
End If
Next x
'if an entry the same week wasn't found, set update row to new row
If updateRow = 0 Then updateRow = endRow + 1
'update or add information
wsDates.Cells(updateRow, 1).Formula = Application.UserName
wsDates.Cells(updateRow, 2).Formula = Format(Now, "mm/dd/yyyy")
wsDates.Cells(updateRow, 3).Formula = Format(Now, "HH:mm:ss")
End If
End Sub