I faced with problem how macros works after start using Office365. In general macros should fill WORD template tags and bookmarks from txt data file. The problem is somtimes same data from data file doesn't past into template and there isn't any logics. It may be first,last, middele records of table. And more over most of times macros fill all data correctly. In Office2013/2016 all work properly.
Is there any ideas about this?
Macros code
Option Explicit
Type t_Ar
Col() As String
End Type
Dim isAutoOpen As String, _
WITHOUT_OLE As String, _
USE_JAR As String, _
UseUnicode As String, fs, f
Private Function GetFullPath(FullName As String) As String
Dim NameParts, Res As String, i As Integer
NameParts = Split(FullName, Application.PathSeparator)
Res = NameParts(0)
For i = 1 To UBound(NameParts) - 1
Res = Res + Application.PathSeparator + NameParts(i)
Next
GetFullPath = Res
End Function
Sub AutoOpen()
Dim FileNameData As String, FullPathMacros As String, ParsName, Cnt As Integer, _
AppMacros As Application, DocMacros As Document
'Stop
isAutoOpen = "X"
Set AppMacros = Application
Set DocMacros = AppMacros.ActiveDocument
'Mac косячит, вместо Path возвращает FullName
' FullPathMacros = Application.ActiveDocument.Path
FullPathMacros = GetFullPath(DocMacros.FullName)
ParsName = Split(DocMacros.Name, "_")
Cnt = UBound(ParsName)
If Cnt = 3 Then
If ParsName(0) = "ZWWW" And ParsName(1) = "MACROS" And ParsName(2) = "WORD" Then
If AppMacros.Documents.Count > 1 Then
' AppMacros.ActiveWindow.Visible = False
Else
AppMacros.Visible = False
End If
ParsName = Split(ParsName(3), ".")
FileNameData = FullPathMacros + AppMacros.PathSeparator + "ZWWW_DATA_" + ParsName(0) + ".txt"
FillVariables FileNameData, DocMacros
If WITHOUT_OLE = "X" Then
If AppMacros.Documents.Count > 1 Then
DocMacros.Close
Else
AppMacros.Quit
End If
End If
End If
End If
isAutoOpen = ""
End Sub
Private Function isFileUnicode(NameFileData As String) As Boolean
Dim b1 As Byte, b2 As Byte
isFileUnicode = False
On Error Resume Next
Open NameFileData For Random Access Read As #5 Len = 1
Get #5, 1, b1
Get #5, 2, b2
Close #5
If b1 = 0 Or b2 = 0 Then
isFileUnicode = True
End If
End Function
Private Sub OpenFileData(FileData As String)
Dim CodePageTxt As Integer
If UseUnicode <> "X" Then
Open FileData For Input As #1
Else
CodePageTxt = -2
If UseUnicode = "X" Then
CodePageTxt = -1
End If
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(FileData, 1, 0, CodePageTxt)
End If
End Sub
Private Sub CloseFileData()
If UseUnicode <> "X" Then
Close #1
Else
f.Close
End If
End Sub
Private Function isEndOfFileData() As Boolean
If UseUnicode <> "X" Then
isEndOfFileData = EOF(1)
Else
isEndOfFileData = f.AtEndOfStream
End If
End Function
Private Function ReadLineData() As String
Dim Ln As String
If UseUnicode <> "X" Then
Line Input #1, Ln
Else
Ln = f.ReadLine
End If
ReadLineData = Ln
End Function
Sub MakeFullDir(FullName As String)
Dim ArrName, NewDir As String, Cnt As Integer
ArrName = Split(FullName, Application.PathSeparator)
On Error Resume Next
Err.Clear
Cnt = 0
Do While Cnt < UBound(ArrName)
If NewDir = "" Then
NewDir = ArrName(Cnt)
Else
NewDir = NewDir + Application.PathSeparator + ArrName(Cnt)
End If
Err.Clear
ChDir NewDir
If Err.Number <> 0 Then
Err.Clear
MkDir NewDir
End If
Cnt = Cnt + 1
Loop
End Sub
Public Sub FillVariables(ByVal FileData As String, ByVal DocTempl) ' As Document
UserFormProgress.UserFormProgressShow FileData, DocTempl
End Sub
Public Sub ZWWW_FillVariables(ByVal FileData As String, ByVal DocTempl) ' As Document
Dim fs, f, _
Ln As String, r As Range, Ofs As Range, _
Ar() As t_Ar, i As Long, Cnt As Long, _
value, CurrRange As Range, _
RowsCount As Long, _
MACROSNAME, ErrNumber, VarError, _
Doc As Document, _
RangeStart, RangeEnd, RangeSize, _
NewStart, NewEnd, NewSize, _
RangeTempl, b As Bookmark, Dupl As Range, Fd As Find, _
CheckSpel, CheckGram, PasteAdjTblFormat As Boolean
' FileData As String
' QTable As QueryTable,
Dim Param, _
ProgressStep As Long, _
Psw As String, _
ResDialogPrint, _
TEMP_NAME As String, _
FILE_NAME As String, _
FILE_PATH As String, _
FULL_NAME As String, _
MACROS_NAME As String, _
DEBUG_MODE As String, _
CLOSE_FORM As String, _
PRINTDIALOG As String, _
PROTECT_WB As String, _
StartTime As Date, _
CurrentTime As Date
StartTime = Time * 100000
CurrentTime = StartTime
If isFileUnicode(FileData) Then
UseUnicode = "X"
Else
UseUnicode = ""
End If
RowsCount = 1
ErrNumber = 0
With Application
Set Doc = .ActiveDocument
.DisplayAlerts = wdAlertsNone
.ScreenUpdating = False
End With
With Options
CheckSpel = .CheckSpellingAsYouType
CheckGram = .CheckGrammarAsYouType
.CheckSpellingAsYouType = False
.CheckGrammarAsYouType = False
End With
OpenFileData FileData
Ln = ReadLineData()
Cnt = Ln
Do While Not isEndOfFileData() And Cnt > 0
Cnt = Cnt - 1
Ln = ReadLineData()
Param = Split(Ln, Chr(9))
If UBound(Param) = 1 Then
Select Case Param(0)
Case "TEMP_NAME"
TEMP_NAME = Param(1)
FULL_NAME = GetFullPath(Application.ActiveDocument.FullName) + Application.PathSeparator + TEMP_NAME
FULL_NAME = Replace(FULL_NAME, "\", Application.PathSeparator)
FULL_NAME = Replace(FULL_NAME, "/", Application.PathSeparator)
Case "FILE_NAME"
FILE_NAME = Param(1)
Case "FILE_PATH"
FILE_PATH = Param(1)
FILE_PATH = Replace(FILE_PATH, "\", Application.PathSeparator)
FILE_PATH = Replace(FILE_PATH, "/", Application.PathSeparator)
Case "WITHOUT_OLE"
WITHOUT_OLE = Param(1)
On Error Resume Next
Open Application.ActiveDocument.Path + Application.PathSeparator + Application.ActiveDocument.Name + ".err" For Input As #2
If Err.Number = 0 Then
WITHOUT_OLE = "X"
Close #2
Else
Err.Clear
End If
On Error GoTo 0
Case "USE_JAR"
USE_JAR = Param(1)
Case "MACROSNAME"
MACROS_NAME = Param(1)
Case "DEBUG_MODE"
DEBUG_MODE = Param(1)
Case "CLOSE_FORM"
CLOSE_FORM = Param(1)
Case "PRINTDIALOG"
PRINTDIALOG = Param(1)
Case "PROTECT"
PROTECT_WB = Param(1)
End Select
End If
Loop
If DEBUG_MODE = "X" Then
Application.Visible = True
Stop
End If
If isAutoOpen = "X" And WITHOUT_OLE = "" Then
CloseFileData
Exit Sub
End If
If (WITHOUT_OLE = "X" Or USE_JAR = "X") And FULL_NAME <> "" Then
' Dim App As New Word.Application
Dim App As Word.Application
If Left(UCase(Application.System.OperatingSystem), 7) = "WINDOWS" Then
Set App = New Application
Else
Set App = Application
End If
App.Documents.Open FULL_NAME
Set DocTempl = App.ActiveDocument
'сбросить Режим чтения в Word 2013,
'т.к. не заполняются колонтитулы
If DocTempl.ActiveWindow.View.ReadingLayout = True Then
'недостаточно сбросить Режим чтения,
'т.к. 2013 переводит в режим Черновик
DocTempl.ActiveWindow.View.Type = wdPrintView
End If
Else
Set App = DocTempl.Application
End If
DocTempl.Activate
Set Doc = App.ActiveDocument
PasteAdjTblFormat = App.Options.PasteAdjustTableFormatting
App.Options.PasteAdjustTableFormatting = False
If DEBUG_MODE = "X" Then
App.Visible = True
App.ScreenUpdating = True
Else
App.ScreenUpdating = False
App.DisplayAlerts = wdAlertsNone
End If
Cnt = 0
i = 0
Do While Not isEndOfFileData()
i = i + 1 'f.Line
Ln = ReadLineData()
ReDim Preserve Ar(1 To i) As t_Ar
Ar(i).Col = Split(Ln, Chr(9), 6, vbBinaryCompare)
Loop
CloseFileData
ProgressStep = UBound(Ar, 1) / 10
If ProgressStep > 50 Then
ProgressStep = 50
End If
If ProgressStep < 1 Then
ProgressStep = 1
End If
Err.Clear
ErrNumber = 0
Set r = Doc.Range
VarError = 0
i = 0
Do While Not i >= UBound(Ar, 1)
i = i + 1
App.ScreenUpdating = True
If DEBUG_MODE = "X" Then
App.ScreenUpdating = True
Else
App.ScreenUpdating = False
End If
'If i Mod ProgressStep = 0 Then
CurrentTime = Time * 100000 - StartTime
If CurrentTime > 1 Then
CurrentTime = Time * 100000
StartTime = CurrentTime
Dim ScrUpd As String
If DEBUG_MODE = "X" Then
ScrUpd = ", ScreenUpdating = "
If App.ScreenUpdating Then
ScrUpd = ScrUpd + "true"
Else
ScrUpd = ScrUpd + "false"
End If
End If
ProgressBar i, UBound(Ar, 1), FULL_NAME + ScrUpd
End If
With Ar(i)
' VarName = .Col(0)
' VarNum = .Col(1)
' FindText = .Col(2)
' Value = .Col(5)
' ErrNumber = 0
On Error Resume Next
If .Col(0) = "" Then
Set r = Doc.Range
ErrNumber = Err.Number
Else
If .Col(0) <> "*" Then
'At new VarName
Set b = Doc.Bookmarks(.Col(0))
Set r = b.Range
Set CurrRange = r.Duplicate
ErrNumber = Err.Number
If ErrNumber = 0 Then
r.Copy
'RowsCount = r.Rows.Count
RangeStart = r.Start
RangeEnd = r.End
RangeSize = RangeEnd - RangeStart
Doc.UndoClear
End If
If DEBUG_MODE = "X" Then
b.Select
r.Select
CurrRange.Select
End If
End If
If ErrNumber = 0 Then
If .Col(1) <> "*" Then
'At new VarNum
If .Col(1) <> 0 Then
r.Move 10, 1 'RowsCount
If DEBUG_MODE = "X" Then
r.Select
End If
If .Col(3) = "V" Then
Err.Clear
Set RangeTempl = Doc.Bookmarks(.Col(5)).Range
VarError = Err.Number
If DEBUG_MODE = "X" Then
RangeTempl.Select
End If
If VarError = 0 Then
NewStart = RangeTempl.Start
NewEnd = RangeTempl.End
RangeTempl.Copy
r.PasteAndFormat wdListCombineWithExistingList '(wdFormatOriginalFormatting)
NewSize = NewEnd - NewStart
NewStart = r.Start
NewEnd = NewStart + NewSize
r.End = NewEnd
If DEBUG_MODE = "X" Then
r.Select
End If
End If
Else
Set RangeTempl = CurrRange 'b.Range
RangeTempl.Copy
r.PasteAndFormat wdListCombineWithExistingList '(wdFormatOriginalFormatting)
b.Start = CurrRange.Start
b.End = CurrRange.End
NewStart = r.Start
NewEnd = NewStart + RangeSize
r.End = NewEnd
If DEBUG_MODE = "X" Then
r.Select
End If
End If
End If
Doc.UndoClear
End If
End If
End If
If ErrNumber = 0 Then
If .Col(2) = "" Then
If .Col(3) = "" Or .Col(3) = "S" Then
If DEBUG_MODE = "X" Then
r.Select
End If
r.Text = .Col(5)
ElseIf .Col(3) = "M" Then
Err.Clear
Set Dupl = r.Duplicate
If DEBUG_MODE = "X" Then
Dupl.Select
End If
'MacrosName = "'" + ActiveWorkbook.Name + "'" + "!" + .Col(5)
'MACROSNAME = .Col(5)
'App.Run MACROSNAME, Dupl
'If Err.Number <> 0 Then
' App.Run MACROSNAME
'End If
RunUserMacros App, .Col(5), Dupl
End If
Else
If .Col(3) = "S" Then
If DEBUG_MODE = "X" Then
r.Select
End If
Set Fd = r.Find
Fd.Execute FindText:=.Col(2), replacewith:=.Col(5), Replace:=wdReplaceAll
End If
End If
End If
End With
Err.Clear
Loop
Doc.UndoClear
i = 0
Do While Not i >= UBound(Ar, 1)
i = i + 1
With Ar(i)
If (.Col(0) <> "" And .Col(0) <> "*" And _
Val(.Col(1)) <> 0 And .Col(1) <> "*") Then
Err.Clear
Set b = Doc.Bookmarks(.Col(0))
If Err.Number = 0 Then
Set r = b.Range
If DEBUG_MODE = "X" Then
r.Select
End If
r.Delete
Set r = b.Range
If Err.Number = 0 Then
If DEBUG_MODE = "X" Then
r.Select
End If
r.Cells.Delete
End If
End If
End If
If .Col(3) = "V" Then
Err.Clear
Set b = Doc.Bookmarks(.Col(5))
If Err.Number = 0 Then
Set r = b.Range
If DEBUG_MODE = "X" Then
r.Select
End If
r.Delete
Set r = b.Range
If Err.Number = 0 Then
If DEBUG_MODE = "X" Then
r.Select
End If
r.Cells.Delete
End If
End If
ElseIf .Col(3) = "D" Then
Err.Clear
Set b = Doc.Bookmarks(.Col(0))
If Err.Number = 0 Then
Set r = b.Range
If DEBUG_MODE = "X" Then
r.Select
End If
r.Delete
Set r = b.Range
If Err.Number = 0 Then
If DEBUG_MODE = "X" Then
r.Select
End If
r.Cells.Delete
End If
End If
End If
End With
Loop
Doc.UndoClear
With App
.ScreenUpdating = True
.DisplayAlerts = wdAlertsAll
End With
With Options
.CheckSpellingAsYouType = CheckSpel
.CheckGrammarAsYouType = CheckGram
.PasteAdjustTableFormatting = PasteAdjTblFormat
End With
If WITHOUT_OLE = "X" Or USE_JAR = "X" Then
If PROTECT_WB = "X" Then
Err.Clear
Psw = Time
Doc.Protect Type:=3, noreset:=False, Password:=Psw
If Err.Number <> 0 Then
Err.Clear
Doc.Protect Type:=1, noreset:=False, Password:=Psw
End If
End If
Dim New_FULL_NAME As String, ErrSave, Saved_as_PDF As Boolean
New_FULL_NAME = FILE_PATH + FILE_NAME
If UCase(FULL_NAME) <> UCase(New_FULL_NAME) And FILE_NAME <> "" Then 'New_FULL_NAME <> ""
MakeFullDir New_FULL_NAME
If File_as_PDF(New_FULL_NAME) Then
Doc.Save
ErrSave = Save_as_PDF(Doc, New_FULL_NAME)
If ErrSave = 0 Then
Saved_as_PDF = True
End If
Else
Err.Clear
Doc.SaveAs FileName:=New_FULL_NAME
ErrSave = Err.Number
If ErrSave <> 0 Then
Doc.Save
End If
End If
Else
Doc.Save
End If
App.DisplayAlerts = True
App.ScreenUpdating = True
If CLOSE_FORM <> "X" Then
If Not Saved_as_PDF Then
With App
.DisplayAlerts = True
.ScreenUpdating = True
.Visible = True
End With
Else
Open_as_PDF New_FULL_NAME
End If
End If
If PRINTDIALOG = "X" Then
If Not Saved_as_PDF Then
ResDialogPrint = App.Dialogs.Item(wdDialogFilePrint).Show
End If
End If
If CLOSE_FORM = "X" Or _
PRINTDIALOG = "X" Or _
Saved_as_PDF Then
App.Quit
End If
End If
End Sub
Sub RunUserMacros(App, Val, Rng)
Dim MACROSNAME As String, Param1 As String, it_Params, Cnt As Integer
it_Params = Split(Val, Chr(9), 2, vbBinaryCompare)
Cnt = UBound(it_Params)
On Error Resume Next
Err.Clear
If Cnt >= 1 Then
MACROSNAME = it_Params(0)
Param1 = it_Params(1)
App.Run MACROSNAME, Rng, Param1
If Err.Number <> 0 Then
App.Run MACROSNAME, Param1
End If
Else
MACROSNAME = Val
App.Run MACROSNAME, Rng
If Err.Number <> 0 Then
App.Run MACROSNAME
End If
End If
Err.Clear
End Sub
Sub ProgressBar(LenPart, LenAll, Txt)
UserFormProgress.LabelText.Caption = Txt
UserFormProgress.LabelProgress.Width = (LenPart / LenAll) * UserFormProgress.FrameProgress.Width
' UserFormProgress.Show
UserFormProgress.Repaint
DoEvents
End Sub
I'm making a VBA-project and want to simplify the following if-statements, because i need to this following 11 times more, for each person.
'CTK opportunities
If result = "CTK" And ToggleButton1 = True Then Range("B4").Value = "X"
If result = "CTK" And ToggleButton2 = True Then Range("C4").Value = "X"
If result = "CTK" And ToggleButton3 = True Then Range("D4").Value = "X"
If result = "CTK" And ToggleButton4 = True Then Range("E4").Value = "X"
If result = "CTK" And ToggleButton5 = True Then Range("F4").Value = "X"
If result = "CTK" And ToggleButton6 = True Then Range("G4").Value = "X"
If result = "CTK" And ToggleButton7 = True Then Range("H4").Value = "X"
If result = "CTK" And ToggleButton8 = True Then Range("I4").Value = "X"
If result = "CTK" And ToggleButton9 = True Then Range("J4").Value = "X"
If result = "CTK" And ToggleButton10 = True Then Range("K4").Value = "X"
If result = "CTK" And ToggleButton11 = True Then Range("L4").Value = "X"
If result = "CTK" And ToggleButton12 = True Then Range("M4").Value = "X"
'Next person
you could try this:
Dim ctrl As Control
If result = "CTK" Then
For Each ctrl In Me.Controls
If InStr(ctrl.Name, "ToggleButton") > 0 Then
If ctrl.Value Then Cells(4, CInt(Replace(ctrl.Name, "ToggleButton", "")) + 1).Value = "X"
End If
Next ctrl
End If
In addition to factorizing the test on "CTK", you can also define an array for your ToggleButtons and iterate on it:
toggleButtons = Array(ToggleButton1, ToggleButton2, .... , ToggleButton12)
If(result = CTK) Then
For i = 0 to UBound(toggleButtons)
If toggleButtons[i] = True Then Cells(4, i+2).Value = "X"
Next
End If
If result = "CTK" Then
If ToggleButton1 = True Then
Range("B4").Value= "X"
ElseIf ToggleButton2 = True Then
Range("C4").Value = "X"
ElseIf...........etc
I am working on a sheet that has sections which hides/shows a number of rows based on a cell value (between 1-10). At the moment, I have a handful of nested if statements. This has made my workbook painfully slow. Is there a way to shrink this code? Thanks.
If Range("B87").Value = 10 Then
Rows("88:98").EntireRow.Hidden = False
Else
If Range("B87").Value = 9 Then
Rows("98").EntireRow.Hidden = True
Rows("88:97").EntireRow.Hidden = False
Else
If Range("B87").Value = 8 Then
Rows("97:98").EntireRow.Hidden = True
Rows("88:96").EntireRow.Hidden = False
Else
If Range("B87").Value = 7 Then
Rows("96:98").EntireRow.Hidden = True
Rows("88:95").EntireRow.Hidden = False
Else
If Range("B87").Value = 6 Then
Rows("95:98").EntireRow.Hidden = True
Rows("88:94").EntireRow.Hidden = False
Else
If Range("B87").Value = 5 Then
Rows("94:98").EntireRow.Hidden = True
Rows("88:93").EntireRow.Hidden = False
Else
If Range("B87").Value = 4 Then
Rows("93:98").EntireRow.Hidden = True
Rows("88:92").EntireRow.Hidden = False
Else
If Range("B87").Value = 3 Then
Rows("92:98").EntireRow.Hidden = True
Rows("88:91").EntireRow.Hidden = False
Else
If Range("B87").Value = 2 Then
Rows("91:98").EntireRow.Hidden = True
Rows("88:90").EntireRow.Hidden = False
Else
If Range("B87").Value = 1 Then
Rows("90:98").EntireRow.Hidden = True
Rows("88:89").EntireRow.Hidden = False
Else
If Range("B87").Value = 0 Then
Rows("88:98").EntireRow.Hidden = True
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
You have a whole lot of basically the same code. I took a look and tried to make it more arithmetical, which shortens the code. See if this works:
Sub t()
Dim myVal As String
Dim mainRow As Long, tweakRow As Long
Dim hideRange As Range, showRange As Range
Dim row1 As Long, row2 As Long
mainRow = 98
myVal = Range("B87").Value
If myVal = 10 Then
Rows(mainRow - 10 & ":" & mainRow - 10 + myVal).EntireRow.Hidden = False
ElseIf myVal >= 1 And myVal <= 9 Then
tweakRow = mainRow - 10
row1 = (mainRow - (9 - myVal))
row2 = (mainRow - (10 - myVal))
Set hideRange = Rows(row1 & ":" & mainRow).EntireRow
Set showRange = Rows(tweakRow & ":" & row2).EntireRow
Debug.Print "For a value of " & myVal & ", we will hide range: " & hideRange.Address & ", and show range: " & showRange.Address
hideRange.Hidden = True
showRange.Hidden = False
ElseIf myVal = 0 Then
Rows(mainRow - 10 & ":" & mainRow).EntireRow.Hidden = True
End If
End Sub
I might try a case statement.
Oh, or even use the ElseIf option which would reduce the amount of EndIf statements at the very least.
I think the case code looks something like this:
Select Range("B87").value
Case "1"
Case "2"
...
End Select
You don't need to use EntireRow when using Rows or 'EntireColumnwhen usingColumns`.
Rows("88:98").Hidden = True
If Range("B87").Value > 0 Then
Rows(88).Resize(1 + Range("B87").Value).Hidden = False
End If
I have the following basic script that merges cells with the same value in Column R
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("R1:R1000")
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
What I would like to do is repeat this in columns A:Q and S:T but, I would like these columns to be merged in the same merged cell ranges as column R, i.e. if R2:R23 is merged then A2:A23, B2:B23, C2:C23 etc. will also be merge.
Columns A:Q do not contain values, column S:T have values but, these will be the same values throughout the range.
Any ideas
Apols for the earlier edit - this now deals with more than one duplicate in col R.
Note that this approach will work on the current (active) sheet.
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim cval As Variant
Dim currcell As Range
Dim mergeRowStart As Long, mergeRowEnd As Long, mergeCol As Long
mergeRowStart = 1
mergeRowEnd = 1000
mergeCol = 18 'Col R
For c = mergeRowStart To mergeRowEnd
Set currcell = Cells(c, mergeCol)
If currcell.Value = currcell.Offset(1, 0).Value And IsEmpty(currcell) = False Then
cval = currcell.Value
strow = currcell.Row
endrow = strow + 1
Do While cval = currcell.Offset(endrow - strow, 0).Value And Not IsEmpty(currcell)
endrow = endrow + 1
c = c + 1
Loop
If endrow > strow+1 Then
Call mergeOtherCells(strow, endrow)
End If
End If
Next c
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub mergeOtherCells(strw, enrw)
'Cols A to T
For col = 1 To 20
Range(Cells(strw, col), Cells(enrw, col)).Merge
Next col
End Sub
You can try the below code as well. It would require you to put a 'No' after the last line in column R (R1001) so as to end the while loop.
Sub Macro1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
flag = False
k = 1
While ActiveSheet.Cells(k, 18).Value <> "No"
i = 1
j = 0
While i < 1000
rowid = k
If Cells(rowid, 18).Value = Cells(rowid + i, 18).Value Then
j = j + 1
flag = True
Else
i = 1000
End If
i = i + 1
Wend
If flag = True Then
x = 1
While x < 21
Range(Cells(rowid, x), Cells(rowid + j, x)).Merge
x = x + 1
Wend
flag = False
k = k + j
End If
k = k + 1
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Please help I want to know exactly what is going on in this code for a questions and answers exam tomorrow.
I don't need any help with writing the code because that would be cheating. I made a tiny few mistakes please forgive me I rectified most of theses I don't need help with the mistakes just with the comments and understanding mostly how it works.
Private Sub Command1_Click()
MSComm1.Output = "83" + Chr$(13)
End Sub
Private Sub Form_Load()
MSC1.PortOpen = True
Average_val = 0
minimum_val = 255
maximum_val = 0
Screenshotofsinewave.Left = 0
Screenshotofsinewave.Channel(0).TraceVisible = True
Screenshotofsinewave.Channel(0).MarkersVisible = True
sumofall_val = 0
Screenshotofsinewave.TitleVisible = False
Screenshotofsinewave.Top = 0
Screenshotofrectifiedsinewave.TitleVisible = False
Screenshotofrectifiedsinewave.Channel(0).TraceVisible = True
Screenshotofrectifiedsinewave.Channel(0).MarkersVisible = True
Screenshotofrectifiedsinewave.Top = 0
Screenshotofrectifiedsinewave.Left = 0
Screenshotoflevelshiftedsinewave.Top = 0
Screenshotoflevelshiftedsinewave.Left = 0
Screenshotoflevelshiftedsinewave.TitleVisible = False
Screenshotoflevelshiftedsinewave.Channel(0).TraceVisible = True
Screenshotoflevelshiftedsinewave.Channel(0).MarkersVisible = True
End Sub
Private Sub MSC1_OnComm()
Dim number_val
Dim number1_val
Dim Average_val
Dim com1_val
p = 0
q = 0
r = 0
s = 0
t = 0
Dim Xarr(50) As Single
Dim Yarr(50) As Single
Dim number2_val
Dim number3_val
Dim Snapshotofsinewave
Dim string1_out As String
Dim string1_in As String
Dim counter As Single
Dim sample_rate As Integer
Select Case MSC1.CommEvent
Case comEvReceive
minimum_val = 255
string1_in = MSC1.Input
Screenshotofsinewave.Channel(0).Clear
Screenshotofrectifiedsinewave.Channel(0).Clear
Screenshotoflevelshiftedsinewave.Channel(0).Clear
counter = 0
comm_count = comm_count + 1
For sample_rate = 1 To 150 Step 3
string1_out = Mid(string1_in, sample_rate, 3)
counter = counter + 1
number_val = Val(string1_out)
Xarr(counter) = counter
Yarr(counter) = number_val
Screenshotofsinewave.Channel(0).AddXY counter, number_val
If number_val > maximum_val Then
maximum_val = number_val
MaxVoltage.Value = maximum_val
End If
If number_val < minimum_val Then
minimum_val = number_val
MinVoltage.Value = number_val
End If
sumofall_val = number_val + sumofall_val
Average_value = sumofall_val / 50
AverageVoltage.Value = Average_value
Next sample_rate
counter = 0
sumofall_val = 0
For sample_rate = 1 To 150 Step 3
string1_out = Mid(string1_in, sample_rate, 3)
counter = counter + 1
number_val = Val(string1_out)
number_val = number1_val - Average_value
number_val = numer_val
If num_val1 < 0 Then
number_val = number_val * -1
End If
Xarr(counter) = counter
Yarr(counter) = number1_val
Screenshotofrectifiedsinewave.Channel(0).AddXY counter, number1_val
Next sample_rate
counter = 0
For sample_rate = 1 To 150 Step 3
string1_out = Mid(string1_in, sample_rate, 3)
Count = Count + 1
number_val = Val(string1_out)
number2_val = number_val + Average_value
Xarr(Count) = counter
Yarr(Count) = number2_val
LevelShifted.Channel(0).AddXY Count, number_val2
sumofall_val = number_val + sumofall_val
Next sample_rate
counter = com1_val
Snapshotofsinewave.Value = com1_val
End Select
End Sub
Private Sub Frame4_DragDrop(Source As Control, X As Single, Y As Single)
End Sub
Private Sub Uploaddata_Click()
If GXSwitch1.SwitchOn = True Then
led1.LampOn = True
p = 8
Else
led1.LampOn = False
p = 0
End If
If GXSwitch2.SwitchOn = True Then
led2.LampOn = True
q = 4
Else
led2.LampOn = False
q = 0
End If
If GXSwitch3.SwitchOn = True Then
led3.LampOn = True
r = 4
Else
led3.LampOn = False
r = 0
End If
If GXSwitch4.SwitchOn = True Then
led4.LampOn = True
s = 8
Else
led4.LampOn = False
s = 0
End If
t = p + q + r + s
If t = 0 Then
MSC1.Output = "0" + Chr$(13)
End If
If t = 1 Then
MSC1.Output = "1" + Chr$(13)
End If
If t = 2 Then
MSC1.Output = "2" + Chr$(13)
End If
If t = 3 Then
MSC1.Output = "3" + Chr$(13)
End If
If t = 4 Then
MSC1.Output = "4" + Chr$(13)
End If
If t = 5 Then
MSC1.Output = "5" + Chr$(13)
End If
If t = 6 Then
MSC1.Output = "6" + Chr$(13)
End If
If t = 7 Then
MSC1.Output = "7" + Chr$(13)
End If
If t = 8 Then
MSC1.Output = "8" + Chr$(13)
End If
If t = 9 Then
MSC1.Output = "9" + Chr$(13)
End If
If t = 10 Then
MSC1.Output = "10" + Chr$(13)
End If
If t = 11 Then
MSC1.Output = "11" + Chr$(13)
End If
If t = 12 Then
MSC1.Output = "12" + Chr$(13)
End If
If t = 13 Then
MSC1.Output = "13" + Chr$(13)
End If
If t = 14 Then
MSC1.Output = "14" + Chr$(13)
End If
If t = 15 Then
MSC1.Output = "15" + Chr$(13)
End If
End Sub
Depends on several factors...
Dim average_val, x As Decimal ' decimal
Dim average_val = 3.2D ' decimal if Option Infer On
Dim average_val = 3.2D ' object with boxed decimal if Option Infer Off
Dim average_val ' Object if Option Strict Off, otherwise an error