Option Explicit
Sub ExtractLatLng()
Dim MyFolder As String, MyFile As String, textline As String, x As Workbook
Dim r As Integer, pos As Integer, JJ As Integer, JJJ As Integer, JK As Integer
Dim File As String, Depth As String, Sensor As Integer, Hit As Integer
Dim Combo As String, DepthIncrement As Double, StationDepth As Double
Dim J As Integer, test As String, iyear As String, YearCheck As Double, SampleDate As Double, DateTest As Double
Dim Station As String, PreviousSampleDate As Double
Dim MyFileName As String, ENDline As Integer
Dim name0 As String
Dim CruiseDate As String
Dim NewDepth As String
Dim LastDepth As String
Dim iFn As Integer
Dim strFilename As String, NewFilename As String
Dim strFileContent As String
Dim v As Variant
Dim i As Integer
Dim wb As Workbook
Dim sh As Worksheet
Dim arrCount As Integer
Dim ub As Integer
'Application.ScreenUpdating = False
Worksheets("sheet1").Cells.ClearContents
Worksheets("Sheet1").Cells(1, 1).Value = "Station"
Worksheets("Sheet1").Cells(1, 2).Value = "Sample Date"
Worksheets("Sheet1").Cells(1, 3).Value = "Cruise Date"
Worksheets("Sheet1").Cells(1, 4).Value = "DO"
Worksheets("Sheet1").Cells(1, 5).Value = "Station Depth"
Worksheets("Sheet1").Cells(1, 6).Value = "Sample Depth"
Worksheets("Sheet1").Cells(1, 7).Value = "Sensor Code"
Worksheets("Sheet1").Cells(1, 9).Value = "File Name"
Worksheets("Sheet1").Cells(3, 12).Value = "Running"
J = 1
YearCheck = DateValue(Worksheets("Sheet2").Cells(10, 11))
Do While J < 25
iyear = Worksheets("Sheet2").Cells(6, 11)
DepthIncrement = Worksheets("Sheet2").Cells(8, 11)
Worksheets("sheet3").Cells.ClearContents
' My source file below (MyFile) has to have the rows altered so it reads last line to first line.
'The code below takes data from MyFile and reverses the order in Sheet3
'Rewrite GLNPO data inversing bottom to top in Sheet3
MyFolder = "C:\Users\scavia\Dropbox (University of Michigan)\Box Sync\Current Folders\Papers, Proposals, & Talks\In Prep\Hypoxia model\GLNPO DO\" & iyear & "\"
File = Worksheets("Sheet2").Cells(J, 1)
MyFile = Dir(MyFolder & File)
strFilename = (MyFolder & File)
iFn = FreeFile
Open strFilename For Input As #iFn
strFileContent = Input(LOF(iFn), iFn)
Close #iFn
v = Split(strFileContent, vbCrLf)
JK = 0
JJ = UBound(v) ' number of rows in Sheet3
ub = UBound(v) - 1
For i = ub To 1 Step -1
JK = JK + 1
Worksheets("sheet3").Cells(JK, 1).Value = v(i)
Next i
' End rewriting
' Here are my source files (a copy is attached)
' Create File Path
MyFolder = "C:\Users\scavia\Dropbox (University of Michigan)\Box Sync\Current Folders\Papers, Proposals, & Talks\In Prep\Hypoxia model\GLNPO DO\2012\"
File = Worksheets("Sheet2").Cells(J, 1)
MyFile = Dir(MyFolder & File)
pos = InStr(File, "ER")
Station = Mid(File, pos, 4)
' Here's were indentify a specfic depth to look for depending on the source file
' At the first occurance of that depth, I access data from that row
DepthIncrement = 1
If Station = "ER30" Then StationDepth = 20.7
If Station = "ER31" Then StationDepth = 21.7
If Station = "ER32" Then StationDepth = 22.2
If Station = "ER36" Then StationDepth = 22.9
If Station = "ER37" Then StationDepth = 23.6
If Station = "ER38" Then StationDepth = 21.7
If Station = "ER42" Then StationDepth = 22
If Station = "ER43" Then StationDepth = 21.9
If Station = "ER73" Then StationDepth = 23.8
If Station = "ER78" Then StationDepth = 22.7
If Station = "ER30" Then Depth = StationDepth - DepthIncrement
If Station = "ER31" Then Depth = StationDepth - DepthIncrement
If Station = "ER32" Then Depth = StationDepth - DepthIncrement
If Station = "ER36" Then Depth = StationDepth - DepthIncrement
If Station = "ER37" Then Depth = StationDepth - DepthIncrement
If Station = "ER38" Then Depth = StationDepth - DepthIncrement
If Station = "ER42" Then Depth = StationDepth - DepthIncrement
If Station = "ER43" Then Depth = StationDepth - DepthIncrement
If Station = "ER73" Then Depth = StationDepth - DepthIncrement
If Station = "ER78" Then Depth = StationDepth - DepthIncrement
r = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row + 1
Hit = 0
' Loop through all of the rows in Sheet3.
JJJ = 0
Do While JJJ < JJ
JJJ = JJJ + 1
Worksheets("Sheet1").Cells(2, 12) = JJJ ' Just a counter
'Get textline from Sheet3
textline = Worksheets("sheet3").Cells(JJJ, 1)
' Look in row for Cruise date and Depth. When found, write to Sheet1
pos = InStr(textline, Depth)
If Hit = 0 And pos = 6 Then
test = Mid(textline, 57, 5)
If test = "" Then Sensor = 1
Worksheets("Sheet1").Cells(J + 1, 1).Value = Station ' Write Startion in column 1
Worksheets("Sheet1").Cells(J + 1, 9) = File ' Write FileName in column 9
Worksheets("Sheet1").Cells(J + 1, 5).Value = StationDepth ' Write Station Depth in column 5
Worksheets("Sheet1").Cells(J + 1, 6).Value = Mid(textline, pos, 5) ' Write Sample Depth in column 6
If Sensor = 1 Then
Worksheets("Sheet1").Cells(J + 1, 4).Value = Mid(textline, pos + 21, 5) ' Write DO in column 4
Else
Worksheets("Sheet1").Cells(J + 1, 4).Value = Mid(textline, pos + 30, 5) ' Write DO in column 4
End If
Hit = 1
Else
End If
'Loo in row for Sampling Time when found, write to Sheet2
pos = InStr(textline, "System UpLoad Time = ")
If pos > 0 Then
Worksheets("Sheet1").Cells(J + 1, 2).Value = DateValue(Mid(textline, pos + 21, 12)) 'Write Sample Date in column 2
SampleDate = DateValue(Mid(textline, pos + 21, 12))
DateTest = YearCheck - SampleDate 'Compare Sample Date and Cruise Date
If Abs(DateTest) < 5 Then
CruiseDate = PreviousSampleDate
Else
CruiseDate = SampleDate
YearCheck = SampleDate
PreviousSampleDate = SampleDate
End If
Worksheets("Sheet1").Cells(J + 1, 3).Value = CruiseDate 'Write Cruise Date in column 3
Worksheets("Sheet1").Cells(J + 1, 7) = Sensor ' Write sensor code in column 7
Exit Do
Else
End If
' End If
r = r + 1
Loop
J = J + 1
Loop
Application.ScreenUpdating = True
MsgBox ("DONE")
End Sub
LinkBack URL
About LinkBacks
scavia 
Register To Reply
Re: Code running very slow
Originally Posted by scavia
Bookmarks