I have created a VBA code that runs through a .txt (Comma separated) file, does some calculations (Works fine), and then re-organizes the data (Adds some headers and moves all the data down one row, gets rid of irrelevant data, Doesn't work on last row) and spits out a new .csv file. I think it has to do with the fact that I am bumping everything down by one row.
Here is the aforementioned code:
Private Sub Workbook_Open()
Sheets("Sheet1").Cells.ClearContents
Application.Visible = False
'---------------------------------------------------------------------------------------
'Choose and open the .TXT file for conversion
Dim answer As Integer
answer = MsgBox("Do you want to process a .TXT file for use in InfoSWMM?", vbYesNo + vbQuestion, "Select .TXT File")
If answer = vbNo Then
Application.Visible = True
Exit Sub
End If
Dim Ret
Ret = Application.GetOpenFilename("Text Files (*.txt),*.txt")
If Ret <> False Then
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & Ret, Destination:=Range("$A$1") _
)
.Name = "Sample"
.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 = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End If
'---------------------------------------------------------------------------------------
'Do data conversion
Dim CountThem As Integer
Dim CountIt2 As Integer
Dim CountIt As Integer
Dim row As Integer
Dim col As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim ant As Double
Dim tester(3) As Double
Dim col_test As Integer
Dim size_test As Integer
Dim rim As Double
Dim Diff2Ele As Double
Dim ResultTxt As String
Dim DiamResultTxt As String
Dim DiamResult As Double
Dim CorrectedDiamResult As Double
Dim Result As Double
Dim MeasDiff As Double
Dim GetElev As Double
Dim GetDiam As String
Dim GetDiam_Val As Double
Dim SVal As Double
Dim Diam2Ft As Double
CountIt = 1
CountIt2 = 1
For row = 1 To ActiveSheet.UsedRange.Rows.Count
If IsEmpty(ActiveSheet.Cells(row, 1).Value) = True Then
Exit For
End If
'Change these values in case feature code library is changed in Carlson, also need to add extra fields
If ActiveSheet.Cells(row, 5).Value = "SD" Or ActiveSheet.Cells(row, 5).Value = "WQ" Or ActiveSheet.Cells(row, 5).Value = "SDCS" Then
col_test = 20
size_test = 19
rim = Val(ActiveSheet.Cells(row, 4).Value) 'Needs val to convert as double
For i = 0 To 3
Result = 0
ResultTxt = Empty
StringLength = Len(Cells(row, col_test))
Str_Length = Len(Cells(row, size_test))
'Gets numbers from string, but ignores 3rd char
DiamResultTxt = Empty
For j = 1 To StringLength
If j = 3 Then GoTo NextIteration 'Skips to next loop on 3rd character, which is an irrelevant number (not one we want)
If IsNumeric(Mid(Cells(row, col_test), j, 1)) = True Or Mid(Cells(row, col_test), j, 1) = "." Then
ResultTxt = ResultTxt & Mid(Cells(row, col_test), j, 1)
End If
NextIteration:
Next j
For j = 1 To Str_Length
If j = 3 Then GoTo nNextIteration 'Skips to next loop on 3rd character, which is an irrelevant number (not one we want)
If IsNumeric(Mid(Cells(row, size_test), j, 1)) = True Then
DiamResultTxt = DiamResultTxt & Mid(Cells(row, size_test), j, 1)
End If
nNextIteration:
Next j
'MsgBox ResultTxt
DiamResult = Val(DiamResultTxt)
CorrectedDiamResult = DiamResult / 12
'MsgBox DiamResult
Result = Val(ResultTxt) 'Needs val to convert as Double
If (InStr(1, ActiveSheet.Cells(row, 34).Value, "TOP") > 0 And InStr(1, ActiveSheet.Cells(row, 34).Value, "PIPE") > 0) Or (InStr(1, ActiveSheet.Cells(row, 36).Value, "TOP") > 0 And InStr(1, ActiveSheet.Cells(row, 36).Value, "PIPE")) Or (InStr(1, ActiveSheet.Cells(row, 38).Value, "TOP") > 0 And InStr(1, ActiveSheet.Cells(row, 38).Value, "PIPE")) Then
tester(i) = Result + CorrectedDiamResult
Else
tester(i) = Result
End If
col_test = col_test + 4
size_test = size_test + 4
Next i
Diff2Ele = WorksheetFunction.Max(tester)
If Diff2Ele = 0 Then
ActiveSheet.Cells(row + 1, 39).Value = "Unable to obtain"
Else
ActiveSheet.Cells(row + 1, 39).Value = rim - Diff2Ele '39 is out of WQ SD and SDCS def. range
End If
End If
'Corrects for top of pipe instances
GetDiam = Empty
If ActiveSheet.Cells(row, 5).Value = "OUTFALL" Then
If InStr(1, ActiveSheet.Cells(row, 18).Value, "TOP") > 0 And InStr(1, ActiveSheet.Cells(row, 18).Value, "PIPE") > 0 Then
GetElev = Val(ActiveSheet.Cells(row, 5).Value)
kLen = Len(Cells(row, 16))
For k = 1 To kLen
If IsNumeric(Mid(Cells(row, 16), k, 1)) = True Or Mid(Cells(row, 16), k, 1) = "." Then
GetDiam = GetDiam & Mid(Cells(row, 16), k, 1)
End If
Next k
GetDiam_Val = Val(GetDiam)
Diam2Ft = GetDiam_Val / 12
ActiveSheet.Cells(row + 1, 39).Value = GetElev - Diam2Ft
Else
ActiveSheet.Cells(row + 1, 39).Value = ActiveSheet.Cells(row, 4).Value
End If
End If
Next row
'---------------------------------------------------------------------------------------
'Prepare sheet re-organization, has to be next step to get altered data from prior process
For row = 1 To ActiveSheet.UsedRange.Rows.Count
If IsEmpty(ActiveSheet.Cells(row, 1).Value) = True Then
Exit For
End If
'ID
ActiveSheet.Cells(row + 1, 44).Value = ActiveSheet.Cells(row, 1).Value
'Description
ActiveSheet.Cells(row + 1, 40).Value = ActiveSheet.Cells(row, 5).Value
'Rim Elevation
If ActiveSheet.Cells(row, 5).Value <> "OUTFALL" Or ActiveSheet.Cells(row, 5).Value <> "DITCH" Then
ActiveSheet.Cells(row + 1, 41).Value = ActiveSheet.Cells(row, 4).Value
End If
'X pos
ActiveSheet.Cells(row + 1, 42).Value = ActiveSheet.Cells(row, 3).Value
'Y pos
ActiveSheet.Cells(row + 1, 43).Value = ActiveSheet.Cells(row, 2).Value
Next row
'---------------------------------------------------------------------------------------
'Re-organize sheet
For row = 1 To ActiveSheet.UsedRange.Rows.Count + 1
If IsEmpty(ActiveSheet.Cells(row, 1).Value) = True Then
If IsEmpty(ActiveSheet.Cells(row, 44).Value) = True Then
Exit For
End If
ElseIf CountIt = 1 Then
ActiveSheet.Cells(row, 1).Value = "ID"
ActiveSheet.Cells(row, 2).Value = "DESC."
ActiveSheet.Cells(row, 3).Value = "RIM ELEV."
ActiveSheet.Cells(row, 4).Value = "YR_INST"
ActiveSheet.Cells(row, 5).Value = "YR_RETIRE"
ActiveSheet.Cells(row, 6).Value = "ZONE"
ActiveSheet.Cells(row, 7).Value = "PHASE"
ActiveSheet.Cells(row, 8).Value = "INV. ELEV."
ActiveSheet.Cells(row, 9).Value = "DEPTH_RIM"
ActiveSheet.Cells(row, 10).Value = "INIT_DPTH"
ActiveSheet.Cells(row, 11).Value = "SURG_DPTH"
ActiveSheet.Cells(row, 12).Value = "POND_AREA"
ActiveSheet.Cells(row, 13).Value = "FLOOD_TYP"
ActiveSheet.Cells(row, 14).Value = "SD_COEFF"
ActiveSheet.Cells(row, 15).Value = "SELECTED"
ActiveSheet.Cells(row, 16).Value = "SYMBOL"
ActiveSheet.Cells(row, 17).Value = "SYMSIZE"
ActiveSheet.Cells(row, 18).Value = "X"
ActiveSheet.Cells(row, 19).Value = "Y"
ActiveSheet.Cells(row, 20).Value = "Z"
ActiveSheet.Cells(row, 21).Value = "SD_MESH"
CountIt = CountIt + 1
Else
ActiveSheet.Cells(row, 1).Value = ActiveSheet.Cells(row, 44).Value
ActiveSheet.Cells(row, 2).Value = ActiveSheet.Cells(row, 40).Value
ActiveSheet.Cells(row, 3).Value = ActiveSheet.Cells(row, 41).Value
ActiveSheet.Cells(row, 4).Value = ""
ActiveSheet.Cells(row, 5).Value = ""
ActiveSheet.Cells(row, 6).Value = ""
ActiveSheet.Cells(row, 7).Value = ""
ActiveSheet.Cells(row, 8).Value = ActiveSheet.Cells(row, 39).Value
ActiveSheet.Cells(row, 9).Value = ""
ActiveSheet.Cells(row, 10).Value = ""
ActiveSheet.Cells(row, 11).Value = ""
ActiveSheet.Cells(row, 12).Value = ""
ActiveSheet.Cells(row, 13).Value = ""
ActiveSheet.Cells(row, 14).Value = ""
ActiveSheet.Cells(row, 15).Value = ""
ActiveSheet.Cells(row, 16).Value = ""
ActiveSheet.Cells(row, 17).Value = ""
ActiveSheet.Cells(row, 18).Value = ActiveSheet.Cells(row, 42).Value
ActiveSheet.Cells(row, 19).Value = ActiveSheet.Cells(row, 43).Value
ActiveSheet.Cells(row, 20).Value = ActiveSheet.Cells(row, 41).Value
ActiveSheet.Cells(row, 21).Value = ""
For CountThem = 22 To 44
ActiveSheet.Cells(row, CountThem).Value = ""
Next CountThem
End If
Next row
'---------------------------------------------------------------------------------------
'Save converted file as .CSV
MsgBox "Choose the desired save location for the .CSV file."
Dim InitialName As String
Dim PathName As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
InitialName = "sfm_output"
PathName = Application.GetSaveAsFilename(InitialFileName:=InitialName, fileFilter:="CSV (Comma delimited) (*.csv), *.csv")
ws.Copy
ActiveWorkbook.SaveAs Filename:=PathName, _
FileFormat:=xlCSV, CreateBackup:=False
MsgBox "Process completed successfully." & vbNewLine & "File saved to:" & vbNewLine & PathName
'---------------------------------------------------------------------------------------
'Close all Workbooks
Application.DisplayAlerts = False
Application.Quit
End Sub
The section(s) in question are either the "Prepare sheet re-organization" section or the "Re-organize sheet section" (or both). Sorry that the code is sloppy currently, I am just trying to get it to work in the first place before I go through and clean it up.
Any help is greatly appreciated!
Edit: Not sure what happened with the indentation in the code snippet..
Edit2: Here is the GitHub with the .xlsm file and a sample input .txt file.
Thanks for the input data. Please add
'at very top
Option Explicit
'after Dim answer As Integer
Application.Visible = True
Stop
'in data conversion
Dim StringLength As Long, Str_Length As Long, kLen As Long
'please note
'rows 14 & 15 are not SD, WQ, SDCS, but fall thru to OUTFALL,
'but neither are TOP/PIPE because column tested s/b 19 (not 18)
'real problem is in Reorg
If IsEmpty(ActiveSheet.Cells(row, 1).Value) = True Then
If IsEmpty(ActiveSheet.Cells(row, 44).Value) = True Then
Exit For
End If
col-A col-AM etc...
1
2 1641.11 SD 1644.01 4302311.81 216897.65 1
3 1641.63 SD 1644.53 4302261.52 216898 2
4 1648.61 SD 1651.26 4302009.62 216670.98 3
5 1648.99 SD 1652.39 4301918.39 216673.01 4
6 1649.51 SD 1654.41 4301857.91 216626.07 5
7 1651.74 SD 1654.64 4301628.69 216756.85 6
8 1662.07 SD 1665.12 4301234.27 216561.5 7
9 1661.76 SD 1665.02 4301232.65 216482.29 8
10 1661.14 SD 1664.94 4301271.11 216498.17 9
11 1669.14 SD 1669.29 4301040.07 216960.04 10
12 1656.85 SD 1661.1 4302020.09 216349.68 11
13 1658.6 SD 1660.64 4302036.86 216345.72 12
14 Unable..WQ 1656.83 4302020.95 216368.26 13
15 1647 OUTFALL 1647 4302151.24 216561.44 14
1648.76 OUTFALL 1648.76 4302059.74 216518.98 15
Col=1 on row 16 is blank, and ExitFor is done one row too soon.
Related
I am a beginner in VBA. I want to pull "Put Options Data" from Yahoo Finance into Excel. Can anybody recommend an Excel VBA script?
You will need to have some modules downloaded before you can start. You will need to download the JSON converter from https://github.com/VBA-tools/VBA-JSON and import the .bas file into a module.
Then you will need to copy the following code into another module:
Function REGEX(strInput As String, matchPattern As String, Optional ByVal outputPattern As String = "$0") As Variant
Dim inputRegexObj As New VBScript_RegExp_55.RegExp, outputRegexObj As New VBScript_RegExp_55.RegExp, outReplaceRegexObj As New VBScript_RegExp_55.RegExp
Dim inputMatches As Object, replaceMatches As Object, replaceMatch As Object
Dim replaceNumber As Integer
With inputRegexObj
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = matchPattern
End With
With outputRegexObj
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "\$(\d+)"
End With
With outReplaceRegexObj
.Global = True
.MultiLine = True
.IgnoreCase = False
End With
Set inputMatches = inputRegexObj.Execute(strInput)
If inputMatches.Count = 0 Then
REGEX = False
Else
Set replaceMatches = outputRegexObj.Execute(outputPattern)
For Each replaceMatch In replaceMatches
replaceNumber = replaceMatch.SubMatches(0)
outReplaceRegexObj.Pattern = "\$" & replaceNumber
If replaceNumber = 0 Then
outputPattern = outReplaceRegexObj.Replace(outputPattern, inputMatches(0).value)
Else
If replaceNumber > inputMatches(0).SubMatches.Count Then
'regex = "A to high $ tag found. Largest allowed is $" & inputMatches(0).SubMatches.Count & "."
REGEX = CVErr(xlErrValue)
Exit Function
Else
outputPattern = outReplaceRegexObj.Replace(outputPattern, inputMatches(0).SubMatches(replaceNumber - 1))
End If
End If
Next
REGEX = outputPattern
End If
End Function
Afterwhich, you'll need to check off some references under Tools - References. Below is a screenshot of what I currently have checked off, although I know there are many you won't need. I know for sure you'll want the ones that start with "Microsoft".
Then copy the following code into the module:
Function GetOptions(ticker, sheetName As String)
Dim XMLPage As New MSXML2.XMLHTTP60
Dim HTMLDoc As New MSHTML.HTMLDocument
Dim strPattern As String: strPattern = "root\.App\.main = ({.+}}}});"
Dim JSON As Object
Dim Key As Variant
Dim i As Integer
' Stop the screen from updating
Application.ScreenUpdating = False
Application.Calculation = xlManual
XMLPage.Open "GET", "https://finance.yahoo.com/quote/" & ticker & "/options?p=" & ticker, False
XMLPage.send
Set JSON = JsonConverter.ParseJson(REGEX(XMLPage.responseText, strPattern, "$1"))
sheets(sheetName).Select
Cells.Select
Selection.ClearContents
On Error Resume Next
' Calls
' Create headers
Cells(1, 1).value = "Calls"
Cells(2, 1).value = "Contract Name"
Cells(2, 2).value = "Last Trade Date"
Cells(2, 3).value = "Strike"
Cells(2, 4).value = "Last Price"
Cells(2, 5).value = "Bid"
Cells(2, 6).value = "Ask"
Cells(2, 7).value = "Change (%)"
Cells(2, 8).value = "Volume"
Cells(2, 9).value = "Open Interest"
Cells(2, 10).value = "Implied Volatility"
i = 3
' Parse JSON
For Each Key In JSON("context")("dispatcher")("stores")("OptionContractsStore")("contracts")("calls")
Cells(i, 1).value = Key("contractSymbol")
Cells(i, 2).value = Key("lastTradeDate")("fmt")
Cells(i, 3).value = Key("strike")("raw")
Cells(i, 4).value = Key("lastPrice")("raw")
Cells(i, 5).value = Key("bid")("raw")
Cells(i, 6).value = Key("ask")("raw")
Cells(i, 7).value = Key("percentChange")("fmt")
Cells(i, 8).value = Key("volume")("raw")
Cells(i, 9).value = Key("openInterest")("raw")
Cells(i, 10).value = Key("impliedVolatility")("fmt")
i = i + 1
Next Key
i = i + 2
' Puts
' Create headers
Cells(i - 1, 1).value = "Puts"
Cells(i, 1).value = "Contract Name"
Cells(i, 2).value = "Last Trade Date"
Cells(i, 3).value = "Strike"
Cells(i, 4).value = "Last Price"
Cells(i, 5).value = "Bid"
Cells(i, 6).value = "Ask"
Cells(i, 7).value = "Change (%)"
Cells(i, 8).value = "Volume"
Cells(i, 9).value = "Open Interest"
Cells(i, 10).value = "Implied Volatility"
i = i + 1
' Parse JSON
For Each Key In JSON("context")("dispatcher")("stores")("OptionContractsStore")("contracts")("puts")
Cells(i, 1).value = Key("contractSymbol")
Cells(i, 2).value = Key("lastTradeDate")("fmt")
Cells(i, 3).value = Key("strike")("raw")
Cells(i, 4).value = Key("lastPrice")("raw")
Cells(i, 5).value = Key("bid")("raw")
Cells(i, 6).value = Key("ask")("raw")
Cells(i, 7).value = Key("percentChange")("fmt")
Cells(i, 8).value = Key("volume")("raw")
Cells(i, 9).value = Key("openInterest")("raw")
Cells(i, 10).value = Key("impliedVolatility")("fmt")
i = i + 1
Next Key
Application.Calculation = xlAutomatic
End Function
FINALLY, we arrive at the ending. You now have a function that takes in the ticker symbol and sheet that's being printed to. The following code shows the whole program being put to use:
Sub OptionTest()
Dim tick, shtName As String
tick = "AAPL"
shtName = "test"
Call GetOptions(tick, shtName)
End Sub
I noticed that there was a single piece of data missing (volume for AAPL210709P00146000), so the Yahoo options data isn't infallible.
I am a complete novice at Excel VBA and I am currently attempting a project on Excel VBA. I have created a UserForm that would allow the user to enter data onto the Excel Sheet by completing the fields in the UserForm. I have tested all the codes individually and they have worked fine.
For the user to access the UserForm, I have added an ActiveX Command Button on a separate sheet on the same workbook. However, when accessing the UserForm from the ActiveX Command Button, some of the codes do not run (mainly the code that flags out the duplicate entry, as well as the code that generates serial numbers).
Where did I go wrong in my code?
This is my code to adding new data as well as the code to flag out duplicate entries. When opening the UserForm from the ActiveX Command Button, adding new data works fine but it does not flag out duplicate entries in the data. (However, testing the code itself in VBA works perfectly fine).
Private Sub cmdAddNewCustomer_Click()
Dim count As Long
Dim lastrow As Long
Dim lCustomerID As String
Dim ws As Worksheet
Set ws = Worksheets("Customer Data")
'find first empty row in database
lrow = ws.Cells.Find(what:="*", searchorder:=xlRows, _
Searchdirection:=xlPrevious, LookIn:=xlValues).Row + 1
lCustomerID = txtCustomerID
count = 0
With ws
For currentrow = 1 To lrow
If lCustomerID = Cells(currentrow, 1) Then
count = count + 1
End If
If count > 1 Then
.Cells(currentrow, 1).Value = ""
.Cells(currentrow, 2).Value = ""
.Cells(currentrow, 3).Value = ""
.Cells(currentrow, 4).Value = ""
.Cells(currentrow, 5).Value = ""
.Cells(currentrow, 6).Value = ""
.Cells(currentrow, 7).Value = ""
.Cells(currentrow, 8).Value = ""
.Cells(currentrow, 9).Value = ""
.Cells(currentrow, 10).Value = ""
.Cells(currentrow, 11).Value = ""
.Cells(currentrow, 12).Value = ""
.Cells(currentrow, 13).Value = ""
.Cells(currentrow, 14).Value = ""
MsgBox ("CustomerID already exists!")
End If
If count = 0 Then
.Cells(lrow, 1).Value = Me.txtCustomerID.Value
.Cells(lrow, 2).Value = Me.txtCustomerName.Value
.Cells(lrow, 3).Value = Me.cboCustomerStatus.Value
.Cells(lrow, 4).Value = Me.txtContactPerson.Value
.Cells(lrow, 5).Value = Me.cboDepartment.Value
.Cells(lrow, 6).Value = Me.txtPosition.Value
.Cells(lrow, 7).Value = Me.cboRoleType.Value
.Cells(lrow, 8).Value = Me.txtofficeHP1.Value
.Cells(lrow, 9).Value = Me.txtOfficeHP2.Value
.Cells(lrow, 10).Value = Me.txtMobileHP1.Value
.Cells(lrow, 11).Value = Me.txtMobileHP2.Value
.Cells(lrow, 12).Value = Me.txtEmail1.Value
.Cells(lrow, 13).Value = Me.txtEmail2.Value
.Cells(lrow, 14).Value = Me.txtEmail3.Value
End If
Next currentrow
End With
'clear the data
Me.txtCustomerName.Value = ""
Me.cboCustomerStatus.Value = ""
Me.txtContactPerson.Value = ""
Me.cboDepartment.Value = ""
Me.txtPosition.Value = ""
Me.cboRoleType.Value = ""
Me.txtofficeHP1.Value = ""
Me.txtOfficeHP2.Value = ""
Me.txtMobileHP1.Value = ""
Me.txtMobileHP2.Value = ""
Me.txtEmail1.Value = ""
Me.txtEmail2.Value = ""
Me.txtEmail3.Value = ""
End Sub
This is the code to generate serial numbers. (Same problem, does not work when accessed via ActiveX Command Button but works fine when tested individually in VBA).
Sub FindCustomerID()
Dim lastrow
Dim lastnum As Long
Dim ws As Worksheet
Set ws = Worksheets("Customer Data")
If Me.cboCountry = "" Or Me.txtCustomerName = "" Then
Exit Sub
End If
serialno = 1
lastrow = ws.Cells(Rows.count, 1).End(xlUp).Row
CountryCode = UCase(Left(Me.cboCountry, 3))
CustomerCode = UCase(Left(Me.txtCustomerName, 10))
'assemble them into CustomerID
CustomerID = CountryCode & CustomerCode & serialno
For currentrow = 2 To lastrow
If CustomerID = Cells(currentrow, 1) Then
'find last number that applies
serialno = serialno + 1
End If
're-assign customerID with new serial number
CustomerID = CountryCode & CustomerCode & serialno
Next currentrow
Me.lblCustomerID = CustomerID
End Sub
And lastly, this is the code from the ActiveX Command Button that brings out the UserForm.
Private Sub cmdNCustomerData_Click()
frmCustomerdata.Show
End Sub
The cause of the problem you described is a missing . to qualify Cells(currentrow, 1). Because you added the ActiveX button to a different sheet, the line
If lCustomerID = Cells(currentrow, 1) Then
accesses Cells(currentrow, 1) of that sheet. To fix this the range needs to be qualified with a . to become
If lCustomerID = .Cells(currentrow, 1) Then
I would also take
If count = 0 Then
.
.
.
End If
outside the loop. You are repeating these lines many times unnecessarily.
The first block of code then becomes:
Private Sub cmdAddNewCustomer_Click()
Dim count As Long
Dim lastrow As Long
Dim lCustomerID As String
Dim ws As Worksheet
Set ws = Worksheets("Customer Data")
'find first empty row in database
lrow = ws.Cells.Find(what:="*", searchorder:=xlRows, _
Searchdirection:=xlPrevious, LookIn:=xlValues).Row + 1
lCustomerID = txtCustomerID
count = 0
With ws
' Count backward to delete rows completely
For currentrow = lrow - 1 To 1 Step -1
If lCustomerID = .Cells(currentrow, 1) Then
count = count + 1
End If
If count > 1 Then
.Cells(currentrow, 1).Resize(1, 14).ClearContents
' Uncomment the following line to delete the whole row completely
'.Rows(currentrow).Delete
End If
Next currentrow
If count > 1 Then
MsgBox (count - 1 " duplicates of CustomerID found and cleared!")
ElseIf count = 0 Then
.Cells(lrow, 1).Value = Me.txtCustomerID.Value
.Cells(lrow, 2).Value = Me.txtCustomerName.Value
.Cells(lrow, 3).Value = Me.cboCustomerStatus.Value
.Cells(lrow, 4).Value = Me.txtContactPerson.Value
.Cells(lrow, 5).Value = Me.cboDepartment.Value
.Cells(lrow, 6).Value = Me.txtPosition.Value
.Cells(lrow, 7).Value = Me.cboRoleType.Value
.Cells(lrow, 8).Value = Me.txtofficeHP1.Value
.Cells(lrow, 9).Value = Me.txtOfficeHP2.Value
.Cells(lrow, 10).Value = Me.txtMobileHP1.Value
.Cells(lrow, 11).Value = Me.txtMobileHP2.Value
.Cells(lrow, 12).Value = Me.txtEmail1.Value
.Cells(lrow, 13).Value = Me.txtEmail2.Value
.Cells(lrow, 14).Value = Me.txtEmail3.Value
End If
End With
'clear the data
Me.txtCustomerName.Value = ""
Me.cboCustomerStatus.Value = ""
Me.txtContactPerson.Value = ""
Me.cboDepartment.Value = ""
Me.txtPosition.Value = ""
Me.cboRoleType.Value = ""
Me.txtofficeHP1.Value = ""
Me.txtOfficeHP2.Value = ""
Me.txtMobileHP1.Value = ""
Me.txtMobileHP2.Value = ""
Me.txtEmail1.Value = ""
Me.txtEmail2.Value = ""
Me.txtEmail3.Value = ""
End Sub
In the FindCustomerID subroutine you have exactly the same problem with the line
If CustomerID = Cells(currentrow, 1) Then
as Cells(currentrow, 1) is not qualified and therefore, should become
If CustomerID = ws.Cells(currentrow, 1) Then
You are also reassigning the CustomerID many times unnecessarily. I would take the reassignment inside the If statement and the loop will become
For currentrow = 2 To lastrow
If CustomerID = ws.Cells(currentrow, 1) Then
'find last number that applies
serialno = serialno + 1
're-assign customerID with new serial number
CustomerID = CountryCode & CustomerCode & serialno
End If
Next currentrow
This way CustomerID is only reassigned if and only if serialno changes.
I'm trying to loop through multiselected list of listbox in excel. but it throws Error "Next without For"
UserForm connects three books. Firstдн, macro should check for matches in book "ToolsDır". If there is a tool, then transfer it from responsible to recipient. then enter this transaction in "TOOLSJOURNAL". and go through all the selected elements of the list box doing the same action. I hope I could explain the problem
Private Sub cmbOK_Click()
Dim wbd, wbs As String
wbd = "...\TOOLS\TOOLSJOURNAL.xlsm"
wbs = "...\TOOLS\TOOLSDIR.xlsm"
If Trim(Me.cboCity.Value) = "" Or Trim(Me.cboReciever.Value) = "" Then
Me.TextDate.SetFocus
MsgBox ("Tool is already in use!")
Else
GetObject (wbs)
Dim lnItem As Long
For lnItem = 0 To Me.ListBox.ListCount - 1
If Me.ListBox.Selected(lnItem) Then
Dim ws As Worksheet
Set ws = Workbooks("TOOLSDIR").Worksheets("TABLE")
Dim rn1, rn2, rn3 As Range
Set rn1 = ws.Range("ID")
Set rn2 = ws.Range("EMPLOYEES")
Set rn3 = ws.Range("DATA")
Dim i, j, k, l As Integer
i = Application.Match(Me.ListBox.Selected(lnItem), ws.Range("ID"), 0)
j = Application.Match(Me.cboRespName.Value, ws.Range("EMPLOYEES"), 0)
k = Application.Match(Me.cboRecName.Value, ws.Range("EMPLOYEES"), 0)
l = rn3.Cells(i, j)
If rn3.Cells(i, j).Value <> 1 Then
MsgBox ("Fill Blank ")
Application.DisplayAlerts = False
Workbooks("TOOLSDIR").Close (False)
Else: rn3.Cells(i, j) = rn3.Cells(i, j) - 1
rn3.Cells(i, k) = rn3.Cells(i, k) + 1
End If
Application.DisplayAlerts = False
Workbooks("TOOLSDIR").Close (True)
With GetObject(wbd)
Dim Database As Worksheet
Set Database = Workbooks("TOOLSJOURNAL").Worksheets("JOURNAL")
Dim NextRow As Long
NextRow = Database.Cells(Database.Rows.Count, 3).End(xlUp).Offset(1, 0).Row
If Database.Range("B4").Value = "" And Database.Range("C4").Value = "" Then
NextRow = NextRow - 1
End If
Database.Cells(NextRow, 3).Value = Me.TextDate.Value
Database.Cells(NextRow, 4).Value = Me.TextPurchaseDate
Database.Cells(NextRow, 5).Value = Me.TextFirstDate.Value
Database.Cells(NextRow, 6).Value = Me.TextDayTotal.Value
Database.Cells(NextRow, 7).Value = Me.cboRegion.Value
Database.Cells(NextRow, 8).Value = Me.cboCity.Value
Database.Cells(NextRow, 9).Value = Me.cboResponsible.Value
Database.Cells(NextRow, 10).Value = Me.cboRespName
Database.Cells(NextRow, 11).Value = Me.ListBox.List(lnItem, 1).Value
Database.Cells(NextRow, 12).Value = Me.ListBox.List(lnItem, 2).Value
Database.Cells(NextRow, 13).Value = Me.ListBox.List(lnItem, 3).Value
Database.Cells(NextRow, 14).Value = Me.cboReciever.Value
Database.Cells(NextRow, 15).Value = Me.cboRecName.Value
Database.Range("B4").Formula = "=If(ISBLANK(C4), """", COUNTA($C$4:C4))"
If NextRow > 4 Then
Workbooks("TOOLSJOURNAL").Worksheets("JOURNAL").Activate
Workbooks("TOOLSJOURNAL").Worksheets("JOURNAL").Range("B4").Select
Selection.AutoFill Destination:=Range("b4:b" & NextRow)
Range("b4:b" & NextRow).Select
End If
End With
Application.DisplayAlerts = False
Workbooks("TOOLSJOURNAL").Close (True)
Next lnItem
End If
Call resetForm
End Sub
I have a workbook with monthly worksheets. One for Emails and one for Calls and I have created two userForms for data entry, one for Emails and one for Calls.
The forms do the job and they enter date in the right place but if I have selected the "August 18 Email" sheet and use the Email form, once the form is submitted it jumps to display the "August 18 Calls" sheet.
I just want it to stay in the selected worksheet, in this case "August 18 Email".
The code for the Emails form is the one below and the one for the Calls is nearly the same but only changing this line : Set ws = Sheets(Format(Date, "mmmm yy") & " calls")
Private Sub CommandButton2_Click()
Dim lRow As Long
Dim ws As Worksheet
Set ws = ActiveSheet
Set ws = Sheets(Format(Date, "mmmm yy") & " emails")
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With ws
If Me.txtDateBox.Value = "" Then
.Cells(lRow, 1).Value = Format(Date, "dd/mmm/yy")
Else
.Cells(lRow, 1).Value = Me.txtDateBox.Value
End If
myVar = ""
For x = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.Selected(x) Then
If myVar = "" Then
myVar = Me.ListBox2.List(x, 0)
Else
myVar = myVar & "," & Me.ListBox2.List(x, 0)
End If
End If
Next x
.Cells(lRow, 11).Value = myVar
myVarSign = ""
For x = 0 To Me.ListBox3.ListCount - 1
If Me.ListBox3.Selected(x) Then
If myVarSign = "" Then
myVarSign = Me.ListBox3.List(x, 0)
Else
myVarSign = myVarSign & "," & Me.ListBox3.List(x, 0)
End If
End If
Next x
.Cells(lRow, 12).Value = myVarSign
myVarTheme = ""
For x = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(x) Then
If myVarTheme = "" Then
myVarTheme = Me.ListBox1.List(x, 0)
Else
myVarTheme = myVarTheme & "," & Me.ListBox1.List(x, 0)
End If
End If
Next x
.Cells(lRow, 14).Value = myVarTheme
.Cells(lRow, 2).Value = Me.Time.Value
.Cells(lRow, 3).Value = Me.ComboBox1.Value
.Cells(lRow, 4).Value = Me.ComboBox2.Value
.Cells(lRow, 5).Value = Me.ComboBox3.Value
.Cells(lRow, 6).Value = Me.ComboBox4.Value
.Cells(lRow, 7).Value = Me.ComboBox5.Value
.Cells(lRow, 8).Value = Me.ComboBox15.Value
.Cells(lRow, 9).Value = Me.ComboBox6.Value
.Cells(lRow, 10).Value = Me.ComboBox7.Value
.Cells(lRow, 13).Value = Me.ComboBox11.Value
.Cells(lRow, 15).Value = Me.ComboBox16.Value
.Cells(lRow, 16).Value = Me.TextBox2.Value
End With
Me.txtDateBox.Value = ""
Me.Time.Value = ""
Me.ComboBox1.Value = ""
Me.ComboBox2.Value = ""
Me.ComboBox3.Value = ""
Me.ComboBox4.Value = ""
Me.ComboBox5.Value = ""
Me.ComboBox6.Value = ""
Me.ComboBox7.Value = ""
Me.ComboBox11.Value = ""
Me.ComboBox16.Value = ""
Me.ComboBox15.Value = ""
Me.TextBox2.Value = ""
Dim iCount As Integer
For iCount = 0 To Me!ListBox1.ListCount
Me!ListBox1.Selected(iCount) = False
Next iCount
For iCount = 0 To Me!ListBox2.ListCount
Me!ListBox2.Selected(iCount) = False
Next iCount
For iCount = 0 To Me!ListBox3.ListCount
Me!ListBox3.Selected(iCount) = False
Next iCount
End Sub
It could be improved a lot but I am happy if after submission the worksheet in view stays instead to jumping to another one.
As you can see I am only beginning (I have managed to create this with help of others).
If you remove any instances of .Select or .Activate on worksheet, range, or cell objects, your sheet shouldn't change.
If that is not an option, another solution would be to note what sheet you are on when the code is called and then Activate that sheet before ending your sub. Since we do not see all of the userform code, you will have to strategically decide where this goes (as mentioned by #K.Davis, nothing shown switches the sheet so it must be happening in some other code).
When the macro/userform is launched:
Dim StartSheet as Worksheet
Set StartSheet = ActiveSheet
Then, before exiting macro/userform:
StartSheet.Activate
You may have to pass this along as a parameter depending on how your code is structured.
I am trying to put together some codes that I found here and there to build up a small inventory, sales program. I am stuck at a point where the customer basket is finalized and sold items in the basket should be saved in relevant sheets.
As an example,basket data is in sheet1 (A4:g22), needs to be written to sheet2 and sheet3 with finding the first empty cell in column A. Thank you very much for your help in advance.
Private Sub EKSKAYDET_Click()
If Not IsNumeric(Me.eksmiktartxt.Value) Then
MsgBox "Miktari Kontrol Ediniz!"
Me.eksmiktartxt.SetFocus
Exit Sub
End If
If Not IsNumeric(Me.eksreznobox.Value) Then
MsgBox "ÜRÜN KODUNU Kontrol Ediniz!"
Me.eksreznobox.SetFocus
Exit Sub
End If
If eksreznobox.Value = "" Then
MsgBox "ÜRÜN KODU Seçmelisiniz!"
Me.eksreznobox.SetFocus
Exit Sub
End If
If TextBox23 = 0 And TextBox19 = 0 And TextBox20 = 0 And TextBox21 = 0 And TextBox22 = 0 Then
MsgBox "ÖDEME MİKTARI Girmelisiniz!": Exit Sub
Me.TextBox19.SetFocus
End If
If TextBox25.Value = 0 Then
MsgBox "SEPET BOŞ!"
Exit Sub
End If
If TextBox19 = "" And TextBox20 = "" And TextBox21 = "" And TextBox22 = "" And TextBox23 = "" Then
MsgBox "Tutar Girmelisiniz!":
Exit Sub
End If
If eksreznobox.ListCount = 0 Then Exit Sub
ry_bul = eksreznobox.ListIndex + 3
eksadI = Sheets("STOKKARTLARI").Range("D" & ry_bul).Value
EKSSOYADI = Sheets("STOKKARTLARI").Range("E" & ry_bul).Value
textbox12 = Sheets("STOKKARTLARI").Range("h" & ry_bul).Value
TextBox15 = Sheets("STOKKARTLARI").Range("F" & ry_bul).Value
ekstutartxt.Value = eksmiktartxt.Value * textbox12.Value
Dim lRow As Long
Dim ws As Worksheet
Set ws = Worksheets("SATISHAREKETLERİ")
lRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
If Trim(Me.eksreznobox.Value) = "" Then
Me.ekreznobox.SetFocus
MsgBox "Lütfen ÜRÜN KODUNU Girin!"
Exit Sub
End If
With ws
.Cells(lRow, 3).Value = Me.eksreznobox.Value
.Cells(lRow, 1).Value = Me.ekstarihtXT.Value
.Cells(lRow, 4).Value = Me.eksadI.Value
.Cells(lRow, 7).Value = Me.eksmiktartxt.Value
.Cells(lRow, 9).Value = Me.ekstutartxt.Value
.Cells(lRow, 8).Value = Me.textbox12.Value
.Cells(lRow, 5).Value = Me.EKSSOYADI.Value
.Cells(lRow, 6).Value = Me.TextBox15.Value
.Cells(lRow, 2).Value = Me.TextBox26.Value
Dim llRow As Long
Dim ws1 As Worksheet
Set ws1 = Worksheets("STOK")
llRow = ws1.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
If Trim(Me.eksreznobox.Value) = "" Then
Me.ekreznobox.SetFocus
MsgBox "Lütfen ÜRÜN KODUNU Girin!"
Exit Sub
End If
With ws1
.Cells(llRow, 3).Value = Me.eksreznobox.Value
.Cells(llRow, 1).Value = Me.ekstarihtXT.Value
.Cells(llRow, 4).Value = Me.eksadI.Value
.Cells(llRow, 7).Value = Me.eksmiktartxt.Value
.Cells(llRow, 9).Value = Me.ekstutartxt.Value
.Cells(llRow, 8).Value = Me.textbox12.Value
.Cells(llRow, 5).Value = Me.EKSSOYADI.Value
.Cells(llRow, 6).Value = Me.TextBox15.Value
.Cells(llRow, 2).Value = Me.TextBox26.Value
.Cells(llRow, 11).Value = Me.TextBox27.Value
ekstutartxt.Value = eksmiktartxt.Value * textbox12.Value
End With
Dim lllRow As Long
Dim ws2 As Worksheet
Set ws2 = Worksheets("kasa")
lllRow = ws2.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
If Trim(Me.eksreznobox.Value) = "" Then
Me.ekreznobox.SetFocus
MsgBox "Lütfen ÜRÜN KODUNU Girin!"
Exit Sub
End If
Me.TextBox52.Value = "SATIŞ"
With ws2
.Cells(lllRow, 1).Value = Me.ekstarihtXT.Value
.Cells(lllRow, 5).Value = Me.TextBox19.Value
.Cells(lllRow, 6).Value = Me.TextBox20.Value
.Cells(lllRow, 7).Value = Me.TextBox21.Value
.Cells(lllRow, 9).Value = Me.TextBox23.Value
.Cells(lllRow, 3).Value = Me.TextBox51.Value
.Cells(lllRow, 2).Value = Me.TextBox26.Value
.Cells(lllRow, 4).Value = Me.TextBox52.Value
ekstutartxt.Value = eksmiktartxt.Value * textbox12.Value
End With
With kayit_formu.ListBox6
.BackColor = vbWhite
.ColumnCount = 9
.ColumnWidths = "50;33;45;55;60;55;42;43;60"
.ForeColor = vbBlack
If Sheets("SATISHAREKETLERİ").Range("A1") = Empty Then
.RowSource = Empty
Else
.RowSource = "SATISHAREKETLERİ!a1:i" & [SATISHAREKETLERİ!A1048500].End(3).Row
End If
End With
MsgBox "Bir Kayit Yapildi!"
End With
Me.TextBox25.Text = CStr(ThisWorkbook.Sheets("SEPET").Range("G1").Value)
Me.TextBox24.Text = CStr(ThisWorkbook.Sheets("SEPET").Range("G2").Value)
End Sub
You can try this code.
Worksheets(“Sheet1″).Range(“A1:G22″).Copy _
Destination:=Worksheets(“Sheet2″).Range(“E5″)