Can someone help me with this problem. I have this code but it doesn't work. Something is wrong it says "Sub or Function not define".
Sub Macro1()
'
' Macro1 Macro
'
Dim x As Integer, result As String
x = 2
' 1st row
Do While Cells(x, 4).Value = 1
If Cells(x, 3).Value <= Cells(x, 2).Value And Not Cells(x, 4).Value < Cells(x, 1).Value Then
result = "pass"
Else
result = "fail"
End If
Cell(x, 5).Value = result
x = x + 1
Loop
End Sub
Change Cell to Cells and it will work. Excel just wasn't being helpful enough with that error message. It does however select the text for Cell when you have the editor open and try to run it.
Sub Macro1()
'
' Macro1 Macro
'
Dim x As Integer, result As String
x = 2
' 1st row
Do While Cells(x, 4).Value = 1
If Cells(x, 3).Value <= Cells(x, 2).Value And Not Cells(x, 4).Value < Cells(x, 1).Value Then
result = "pass"
Else
result = "fail"
End If
Cells(x, 5).Value = result
x = x + 1
Loop
End Sub
Related
why now return ....Syntax error
Can i put the Sub rutine in the function? Or better way for this?!
Function SumerizePlanArrays(f_String, f_Type)
Set dic = CreateObject("Scripting.Dictionary")
Sub Add(s)
weight = Split(s,"$")(0)
values = Split(s,"$")(1)
pipes = Split(values, "|")
For Each line In pipes
val = Split(line, ",")
if f_Type = 1 then
dic(val(1)) = (dic(val(1))*weight/100) + CInt(val(2))
elseif f_Type = 2 then
dic(val(1)) = dic(val(1)) + CInt(val(2))
end if
Next
End Sub
arrString = Split(f_String,"#")
For i = 0 to UBound(arrString)
'wei = Split(arrString(i),"$")(0)
Add arrString(i)
Next
Set a = CreateObject("System.Collections.ArrayList")
For Each key In dic.Keys
a.Add "0," & key & "," & dic(key)
Next
a.Sort
result = Join(a.ToArray, "|")
SumerizePlanArrays = result
End Function
Microsoft VBScript compilation error '800a03ea'
Syntax error
/inc_func_projects.asp, line 2592
Sub Add(s)
^
No - you can't put a sub within a function, except in JavaScript or in the server side version called JScript. VBScript and JScript are two completely different languages, however.
You should be doing this...
Function SumerizePlanArrays(f_String, f_Type)
Set dic = CreateObject("Scripting.Dictionary")
arrString = Split(f_String,"#")
For i = 0 to UBound(arrString)
'NOTE: Updated the call to reflect comment by sadrasjd...
Add arrString(i, f_Type, dic)
Next
Set a = CreateObject("System.Collections.ArrayList")
For Each key In dic.Keys
a.Add "0," & key & "," & dic(key)
Next
a.Sort
result = Join(a.ToArray, "|")
SumerizePlanArrays = result
End Function
Sub Add(s, type, dic)
'NOTE: ^Updated the parameters to reflect comment by sadrasjd^
weight = Split(s,"$")(0)
values = Split(s,"$")(1)
pipes = Split(values, "|")
For Each line In pipes
val = Split(line, ",")
if type = 1 then
dic(val(1)) = (dic(val(1))*weight/100) + CInt(val(2))
elseif type = 2 then
dic(val(1)) = dic(val(1)) + CInt(val(2))
end if
Next
End Sub
NOTE: Updated the call to reflect the suggestion made by sadrasjd.
I am reading a text file with 5000 strings. Each string contains Date+Time and then 3 values. The delimiter between Date and Time is a space, and then the three values are tab delimited. First string (strData(0)) is just a header, so I do not need that. Last string is just a simple "End".
The below code works, but it takes 1 minute to import into the worksheet! What can I do to improve this, and what is taking time?
Screen updating is off.
'open the file and read the contents
Open strPpName For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
'split the data and write into the correct columns
Row = 3
i = 0
For Each wrd In strData()
If i > 0 Then 'first string is only header
tmpData() = Split(wrd, vbTab)
DateString() = Split(tmpData(0), " ")
If DateString(0) <> "End" Then
ActiveSheet.Cells(Row, 5) = DateString(0) 'Date
ActiveSheet.Cells(Row, 6) = DateString(1) 'Time
ActiveSheet.Cells(Row, 2) = tmpData(1) 'Value1
ActiveSheet.Cells(Row, 3) = tmpData(2) 'Value2
ActiveSheet.Cells(Row, 4) = tmpData(3) 'Value3
Row = Row + 1
Else
GoTo Done
End If
End If
i = i + 1
Next wrd
Done:
Try with something like this:
Dim Values(), N, I
N = 100
ReDim Values(6, N)
...
Do While Not EOF(1)
I = I + 1
If I > N Then
N = N + 100
ReDim Preserve Values(6, N)
End If
Values(0, I) = ...
...
Loop
Range("A1:F" & i) = Values
The loop will work with arrays that in VBA are much faster than working with the sheet.
Excel can handle multiple types of delimiters (tab and space) with get data from text. This is what I have from macro recorder
Sub Macro1()
'
' Macro1 Macro
'
'
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\jeanno\Documents\random.txt", Destination:=Range("$A$1"))
.CommandType = 0
.Name = "random_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
This will be much faster than string manipulation in VBA.
I think the problem is you might be reading the file in Binary. Try the following approach. I ran 5100+ records and it parsed it in under a second.
Public Sub ReadFileToExcel(filePath As String, rowNum As Long)
'******************************************************************************
' Opens a large TXT File, reads the data until EOF on the Source,
' adds the data in a EXCEL File, based on the row number.
' Arguments:
' ``````````
' 1. The Source File Path - "C:\Users\SO\FileName.Txt" (or) D:\Data.txt
' 2. The Row number you wish to start adding data.
'*******************************************************************************
Dim strIn As String, lineCtr As Long
Dim tmpData, DateString
'Open the SOURCE file for Read.
Open filePath For Input As #1
'Loop the SOURCE till the last line.
Do While Not EOF(1)
'Read one line at a time.
Line Input #1, strIn
lineCtr = lineCtr + 1
If lineCtr <> 1 Then
If InStr(strIn, "END") = 0 Then
tmpData = Split(strIn, vbTab)
DateString = Split(tmpData(0), " ")
ActiveSheet.Cells(rowNum, 5) = DateString(0) 'Date
ActiveSheet.Cells(rowNum, 6) = DateString(1) 'Time
ActiveSheet.Cells(rowNum, 2) = tmpData(1) 'Value1
ActiveSheet.Cells(rowNum, 3) = tmpData(2) 'Value2
ActiveSheet.Cells(rowNum, 4) = tmpData(3) 'Value3
rowNum = rowNum + 1
End If
End If
Loop
Debug.Print "Total number of records - " & lineCtr 'Print the last line
'Close the files.
Close #1
End Sub
i have huge problem with my event procedure, it takes ages to run when i want to change more than few cells at once. How it works, well when user changes data in cell the Worksheet_Change adds comments, but first the Worksheet_SelectionChange updates informations for user (i have sumifs in different worksheet where it calculates ACT date for 12 months, and then it display via camer tool on active worksheet).
In know that problem is cuz of constant looping through events.... duno what to do ?!
Thx for help!
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
ActiveSheet.Unprotect Password:="xyz"
For Each cell In Target
If cell.Row > 21 And cell.Column > 9 Then
If cell.Comment Is Nothing Then
cell.AddComment Now & " - " & cell.Value & " - " & Application.UserName
Else
If Val(Len(cell.Comment.Text)) > 255 Then
cell.Comment.Delete
cell.AddComment
cell.Comment.Text _
Now & " - " & cell.Value & " - " & Application.UserName, 1 _
, False
Else
cell.Comment.Text _
vbNewLine & Now & " - " & cell.Value & " - " & Application.UserName, Len(cell.Comment.Text) + 1 _
, False
End If
End If
cell.Comment.Shape.TextFrame.AutoSize = True
End If
Next cell
ActiveSheet.Protect Password:="11opkLnm890", AllowFiltering:=True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim RowNumber As Long, i As Long
Dim MaxRowNumber As Long
MaxRowNumber = Range("A9").Value
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
RowNumber = Target.Row
Set sh_AUXILIARY_PT = ThisWorkbook.Worksheets("AUXILIARY_PT")
If Target.Row > 21 And Target.Row < MaxRowNumber Then
sh_AUXILIARY_PT.Range("AA4").Value = Cells(RowNumber, 1).Value
sh_AUXILIARY_PT.Range("AB4").Value = Cells(RowNumber, 2).Value
sh_AUXILIARY_PT.Range("AC4").Value = Cells(RowNumber, 3).Value
sh_AUXILIARY_PT.Range("AD4").Value = Cells(RowNumber, 4).Value
For i = 14 To 25
sh_AUXILIARY_PT.Cells(8, i).Value = Cells(RowNumber, i - 4).Value
Next i
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
well, you may consider assigning your collection range to an Array and then loop through since Arrays are much faster.
Below I have some code that I have written. It is compeletely effective and gives no errors. However, it is very, very slow. The sub takes a given sheet with a table on it and checks for hidden rows. If all the rows are hidden, it deletes the sheet. If not, then it deletes all the hidden rows.
This is run in another sub, where all things like screenupdating and events are disabled.
I have researched common ways to speed up code (here: How to improve the speed of VBA macro code?, here: http://www.databison.com/how-to-speed-up-calculation-and-improve-performance-of-excel-and-vba/, and here: http://www.ozgrid.com/VBA/SpeedingUpVBACode.htm), but haven't been able to apply too many of them.
Please take a look and let me know what you think I could do to speed this up. If there are any other proper coding mistakes I have made, please let me know those as well.
Thanks!
Sub RhidRow(ByVal count4 As Double) 'count 4 is the total number of possible rows
Dim count6, count1, count9 As Double 'counters to be used
count6 = 2 'begin on row two
count1 = 0 'check for visible rows counter
With ActiveSheet
While count6 < count4
DoEvents
Application.StatusBar = "Checking row " & count6 & " of " & count4 & "."
If Range("A" & CStr(count6)).EntireRow.Hidden = False Then
count1 = count1 + 1 'if there was a visible row, then add one
End If
count6 = count6 + 1 'move to next row to check
Wend
Range("N7") = count6 'so I can hand check results
If count1 = 0 Then 'if there were no visible rows, then set Z1 to 1 and exit
Range("Z1").Value = 1 'to error check in another sub. if Z1=1, then delete
Exit Sub
End If
count6 = 2 'start on row 2
count9 = 1 'count 9
While count9 < count4 'while the row is less than the count of the total rows
DoEvents
Application.StatusBar = count6 & " or " & count9 & " of " & count4
If Range("A" & CStr(count6)).EntireRow.Hidden = True Then
Range("A" & CStr(count6)).EntireRow.Delete 'if row is hidden, delete
Else
count6 = count6 + 1 'if it is not hidden, move to the next row
End If
count9 = count9 + 1 'show what row it is on in the status bar
Wend
End With
End Sub
I have made the change suggested in the comments and gotten rid of ActiveSheet. The speed was unaffected.
Sub RhidRow(ByVal count4 As Double, shtO As Object) 'count 4 is the total number of possible rows
Dim count6, count1, count9 As Double 'counters to be used
count6 = 2 'begin on row two
count1 = 0 'check for visible rows counter
With shtO
While count6 < count4
DoEvents
Application.StatusBar = "Checking row " & count6 & " of " & count4 & "."
If Range("A" & CStr(count6)).EntireRow.Hidden = False Then
count1 = count1 + 1 'if there was a visible row, then add one
End If
count6 = count6 + 1 'move to next row to check
Wend
Range("N7") = count6 'so I can hand check results
If count1 = 0 Then 'if there were no visible rows, then set Z1 to 1 and exit the sub
Range("Z1").Value = 1 'this is used to error check in another sub. if Z1 is 1, then the sheet is deleted
Exit Sub
End If
count6 = 2 'start on row 2
count9 = 1 'count 9
While count9 < count4 'while the row is less than the count of the total rows
DoEvents
Application.StatusBar = "Deleting hidden rows. " & count6 & " or " & count9 & " of " & count4 & " done."
If Range("A" & CStr(count6)).EntireRow.Hidden = True Then
Range("A" & CStr(count6)).EntireRow.Delete 'if the row is hidden, delete it
Else
count6 = count6 + 1 'if it is not hidden, move to the next row
End If
count9 = count9 + 1 'show what row it is on in the status bar
Wend
End With
End Sub
Maybe something like this:
Sub RhidRow(ByVal count4 As Double) 'count 4 should be a Long, not Double
Dim count1 As Long 'counters to be used
Dim ws As Worksheet
Dim rngVis As Range
Dim rngDel As Range
Set ws = ActiveSheet
On Error Resume Next
Set rngVis = ws.Range("A2:A" & count4).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rngVis Is Nothing Then
ws.Range("Z1").Value = 1
Else
For count1 = count4 To 2 Step -1
If ws.Rows(count1).Hidden = True Then
If rngDel Is Nothing Then
Set rngDel = ws.Rows(count1)
Else
Set rngDel = Union(rngDel, ws.Rows(count1))
End If
End If
Next count1
If Not rngDel Is Nothing Then
Application.DisplayAlerts = False
Intersect(rngDel, rngDel.ListObject.DataBodyRange).Delete 'if row is hidden, delete
Application.DisplayAlerts = True
End If
End If
End Sub
This might be a bit quicker:
Sub RowKleaner()
Dim rBig As Range, r As Range, rDelete As Range
ActiveSheet.UsedRange
Set rBig = Intersect(ActiveSheet.UsedRange, Range("A:A"))
Set rDelete = Nothing
For Each r In rBig
If r.EntireRow.Hidden = True Then
If rDelete Is Nothing Then
Set rDelete = r
Else
Set rDelete = Union(rDelete, r)
End If
End If
Next r
If Not rDelete Is Nothing Then
rDelete.EntireRow.Delete
End If
End Sub
the below will delete the sheet (or flag I left the logic for you to decide) if all rows are hidden, or will delete only the hidden rows if not:
Dim rngData As Range, rngVisible As Range, rngHidden As Range
Set rngData = Range("C8:H20")
Set rngVisible = rngData.SpecialCells(xlCellTypeVisible)
Set rngHidden = Range("A:A")
If (rngVisible Is Nothing) Then
' delete sheet or flag
Else
' invert hidden / visible
rngHidden.Rows.Hidden = False
rngVisible.Rows.Hidden = True
' delete hidden and show visible
rngData.SpecialCells(xlCellTypeVisible).Delete
rngVisible.Rows.Hidden = False
End If
Set objReadFile = objFSO.OpenTextFile(objFile.Path, ForReading)
strAll = Split(objReadFile.ReadAll, vbCrLf, -1, vbTextCompare) 'Gets each line from file
i = LBound(strAll)
Do While i < UBound(strAll)
If (InStr(1, strAll(i), "DAU SNo.-C0", vbTextCompare) > 0) Then
i = i + 4 'Skip 4 lines to get to first SN
Do Until InStr(1, strAll(i), "+", vbTextCompare) > 0 'Loop until line includes "+"
strSNO = Split(strAll(i), "|", -1, vbTextCompare)
'put strSNO into next cell in column A
**objSheet.Cells.Offset(1,0).Value = Trim(strSNO(1))**
i = i + 1
Loop
End If
i = i + 1
Loop
This code splits a text file successfully and puts the two values I want in strSNO(1) and strSNO(2). I want to write them into column A row 2 and column B row 2, then put the next value in row 3 in the next iteration of the loop. I tried the offset method and it gave errors. All the help I am finding is for VBA. Can anyone tell me what to put where the code is in bold to fix it?
EDIT:
Solved it.This is what I did:
strAll = Split(objReadFile.ReadAll, vbCrLf, -1, vbTextCompare) 'Gets each line from file
i = LBound(strAll)
c=2
Do While i < UBound(strAll)
If (InStr(1, strAll(i), "DAU SNo.-C0", vbTextCompare) > 0) Then
i = i + 4 'Skip 4 lines to get to first SN
Do Until InStr(1, strAll(i), "+", vbTextCompare) > 0 'Loop until line includes "+"
strSNO = Split(strAll(i), "|", -1, vbTextCompare)
i = i + 1
objSheet.Cells(c,1).Offset(1,0).Value = Trim(strSNO(1))
objSheet.Cells(c,2).Offset(1,0).Value = Trim(strSNO(2))
c=c+1
Loop
End If
i = i + 1
Loop
Replace
objSheet.Cells.Offset(1,0).Value = Trim(strSNO(1))
with
objSheet.Cells(i,1).Value = Trim(strSNO(1))
objSheet.Cells(i,2).Value = Trim(strSNO(2))
Edit: Are you certain you want the fields 1 and 2 of strSNO? VBScript arrays are 0-based, so the first index is 0, not 1.
To locate an error add some debugging code:
On Error Resume Next
objSheet.Cells(i,1).Value = Trim(strSNO(1))
If Err Then
WScript.Echo i & ": " & strAll(i)
WScript.Echo "strSNO(1) = " & strSNO(1)
WScript.Echo "strSNO(1) is of type " & TypeName(strSNO(1))
End If
Err.Clear
objSheet.Cells(i,2).Value = Trim(strSNO(2))
If Err Then
WScript.Echo i & ": " & strAll(i)
WScript.Echo "strSNO(2) = " & strSNO(2)
WScript.Echo "strSNO(2) is of type " & TypeName(strSNO(2))
End If
On Error Goto 0
If the problem turns out to be that strAll(i) doesn't contain a | for some i, so the Split() produces an array with just one element, you can work around that by something like this:
strSNO = Split(strAll(i) & "|", "|", -1, vbTextCompare)