i need help adjusting my code (transfer data from userform to worksheet
it shows me error compile can't find project library then sit on this word "trim"
Private Sub ButtonNew_Click()
Dim Ad As String
Dim c As Integer
Dim xx As Long
''''''''''''''''''''
For c = 1 To ContColmn
Ad = Cells(1, c).Address(0, 0)
If Len(Trim(Me.Controls(Ad).Value)) = 0 Then
MsgBox "address: " & Me.Controls("xx" & c).Caption & " empty", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "empty cell"
Me.Controls(Ad).SetFocus
Exit Sub
End If
Next
''''''''''''''''''''''
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Sheet2
Lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
For c = 1 To ContColmn
Ad = Cells(1, c).Address(0, 0)
.Cells(Lr, c).Value = Me.Controls(Ad).Value
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
A1.Value = Application.WorksheetFunction.Max(Sheets(2).Range("A2:A5000")) + 1
MsgBox "ok"
End Sub
Related
I want to check if a cell in a sheet s4 has the same value for each cell in the sheet s1
So i tried to "stop" the Next c setting the c value as the previous cell, until the condition be true.
i put msgbox c.Value & "hiiiii" to check the c position, and is always the next cell.
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim s3 As Worksheet
Dim s4 As Worksheet
Set s1 = ThisWorkbook.Sheets("test1")
Set s2 = ThisWorkbook.Sheets("test2")
Set s3 = ThisWorkbook.Sheets("test3")
Set s4 = ThisWorkbook.Sheets("test4")
Dim l As Integer
l = 8
lastrow = s4.Range("J" & s4.Rows.count).End(xlUp).row
Set rd = s4.Range("J2:J" & lastrow)
Set rf = s1.Range("A" & l)
For Each c In rd
msgbox c.Value & "hiiiii"
If rf.Value = "" Then: Exit For
If c.Value = rf.Value Then
s1.Range("B" & l).Value = c.Offset(, -1)
l = 8
Set rf = s1.Range("A" & l)
Else
l = l + 1
Set rf = s1.Range("A" & l)
Set c = c.Offset(-1, 0)
End If
Next c
There's a way to make it works?
Thank you
EDIT 1:
After some hours of breaking my head i changed the code and now it is working:
Dim l As Integer
Dim i As Integer
lastrow = s4.Range("J" & s4.Rows.count).End(xlUp).row
LastRow2 = s1.Range("A" & s1.Rows.count).End(xlUp).row
l = 8
i = 8
Set rd = s4.Range("J2:J" & lastrow)
Set rf = s1.Range("A" & i)
For Each c In rd
If c.Value <> rf.Value Then
For i = 8 To LastRow2
Set rf = s1.Range("A" & i)
If rf.Value = c.Value Then
rf.Offset(, 1).Value = c.Offset(, -1)
End If
Next i
Else
rf.Offset(, 1).Value = c.Offset(, -1)
End If
Next c
End Sub
A special thanks for Cyril and his tip about the another for options.
Screenshots/here refer:
CONSTRUCT
Fixed: comprises list of cells - press CMD button 'RUN' to select which values you want to compare against every populated cell of every other sheet.
This runs the macro Soln() (below).
test1-test3: arbitrary sheets comprising a medley of matching and mis-matched cell values/text etc. (contiguous / isolated cells etc.). Most content in test 1.
Audit_Trail: This will be removed/deleted if it exists when you run the macro so that a fresh sheet can be produced. This will display, for each target cell (selected step 1) and sheet (see 2) every cell (sheet/link/content) that did not match the respective target values.
CODE
(essential modules: Soln(), select cells - all the rest is 'bonus' - hope this works/helps you - assuming I understood issue correclty☺.)
Global addr(), target_cells(), s As String
Sub s_(new_txt)
Application.StatusBar = False
s = s & " --> " & new_txt
Application.StatusBar = s
End Sub
Sub Soln()
Application.StatusBar = False
s_ ("sub soln")
'Application.StatusBar = "Sub Soln()"
ReDim Preserve addr(0), target_cells(0)
Sheets("fixed").Move Before:=Sheets(1)
Call select_cells
Application.ScreenUpdating = False
m = -1
N_ = -1
K_ = -1
'Sheets(1).Activate
If sheet_exists("Audit_Trail") Then
Application.DisplayAlerts = False
Sheets("Audit_Trail").Delete
ThisWorkbook.Sheets.Add( _
After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = "Audit_Trail"
Application.DisplayAlerts = True
End If
With Sheets("Audit_Trail")
.Range("a1").Value = "Target_value"
.Range("b1").Value = "Sheet"
.Range("c1").Value = "Link/Content"
End With
For Each sh In ActiveWorkbook.Sheets
For Each yy In target_cells
sh.Activate
If (sh.Name = "fixed") Or (sh.Name = "Audit_Trail") Then
Exit For
'ActiveSheet.Next.Select
Else
On Error Resume Next
Selection.SpecialCells(xlCellTypeConstants, 23).Select
For Each c In Selection
If c.Value = yy Then
Resume Next
Else
addr_temp = Evaluate("ADDRESS(" & c.Row & "," & c.Column & ",1,1,""" & c.Worksheet.Name & """)")
With Sheets("Audit_Trail")
m = m + 1
.Range("a2").Offset(m).Value = yy
.Range("b2").Offset(m).Value = sh.Name
.Range("c2").Offset(m).Value = "=" & addr_temp
End With
End If
Next
End If
Next
Next
Application.ScreenUpdating = True
Application.StatusBar = False
Call pivot_summary
End Sub
Sub select_cells() '#Tim Williams (2011) - https://stackoverflow.com/questions/7353711/let-the-user-click-on-the-cells-as-their-input-for-an-excel-inputbox-using-vba
s_ ("sub select_cells()")
Dim rRange As Range
N_ = -1
On Error Resume Next
Application.DisplayAlerts = False
Sheets("fixed").Activate
Default_ = Sheets("fixed").Range("J2:J4").Address
Set rRange = Application.InputBox(Prompt:= _
"Please select range with cells you would like to compare against every other cell in this workbook.", Title:="SPECIFY RANGE", Default:=Default_, Type:=8)
Application.DisplayAlerts = True
If rRange Is Nothing Then
Exit Sub
Else
For Each c In rRange
N_ = N_ + 1
ReDim Preserve target_cells(0 To N_)
target_cells(N_) = c.Value
Next
End If
Return
End Sub
Function sheet_exists(sh As String) As Boolean
s_ ("sheet_exists()")
'Dim w As Excel.Worksheet
On Error GoTo eHandle
Set w = ThisWorkbook.Worksheets(sh)
sheet_exists = True
Exit Function
eHandle:
sheet_exists = False
End Function
'******not really required - could ignore *********'
Sub pivot_summary()
Range("a1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
Selection, Version:=8).CreatePivotTable TableDestination:= _
ActiveSheet.Range("g2"), TableName:="PivotTable5", _
DefaultVersion:=8
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Target_value")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Sheet")
.Orientation = xlRowField
.Position = 2
End With
ActiveSheet.PivotTables("PivotTable5").AddDataField ActiveSheet.PivotTables( _
"PivotTable5").PivotFields("Link/Content"), "Sum of Link/Content", xlSum
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Sum of Link/Content")
.Caption = "Count of Link/Content"
.Function = xlCount
End With
ActiveSheet.PivotTables("PivotTable5").CompactLayoutRowHeader = "Target"
Range("H2").Select
ActiveSheet.PivotTables("PivotTable5").DataPivotField.PivotItems( _
"Count of Link/Content").Caption = "# mismatch"
Columns("G:H").Select
Selection.ColumnWidth = 11.27
Selection.Font.Name = "Brush Script MT"
Range("G22").Select
ActiveCell.FormulaR1C1 = "That's all folks! ?"
Range("G23").Select
ActiveWorkbook.Save
End Sub
GIF DEMO
OTHER INFO
To replicate for a single value, simply uapte the list in 1 (fixed) accordingly
This also creates a pivot in the Audit_Trail sheet summarises the extent of mismatches per sheet for each desired 'target value'.
I want to duplicate the code below so it applies to every new sheet.
I have to manually change the code to the new sheet's name. I found loops but that coding didn't work for me. I am trying to create a stop watch function for billing hours.
I can copy sheets and create a copy, but then none of the functions work in the new sheet it says
Run-Time Error 1004: select method of Range class failed
and stops on this line:
Sheets("Client").Range("B" & iRow).Select
Sub Intialize()
Dim iRow As Long
iRow = Sheets("Client").Range("F" & Application.Rows.Count).End(xlUp).Row
'Code to Validate
If Sheets("Client").Range("D" & iRow).Value = "" Then
Sheets("Client").Range("A" & iRow).Value = Format([Today()], "DD-MMM-YYYY")
End If
End Sub
Sub Start_Time()
Dim iRow As Long
iRow = Sheets("Client").Range("F" & Application.Rows.Count).End(xlUp).Row + 1
'Code to Validate
If Sheets("Client").Range("B" & iRow).Value = "" Then
MsgBox "Please select the Task Name from the drop down.", vbOKOnly + vbInformation, "Task Name Blank"
Sheets("Client").Range("B" & iRow).Select
Exit Sub
ElseIf Sheets("Client").Range("D" & iRow).Value <> "" Then
MsgBox "Start Time is aleady captured for the selected Task."
Exit Sub
Else
Sheets("Client").Range("D" & iRow).Value = [Now()]
Sheets("Client").Range("D" & iRow).NumberFormat = "hh:mm:ss AM/PM"
End If
End Sub
Sub End_Time()
Dim iRow As Long
iRow = Sheets("Client").Range("F" & Application.Rows.Count).End(xlUp).Row + 1
'Code to Validate
If Sheets("Client").Range("D" & iRow).Value = "" Then
MsgBox "Start Time has not been captured for this task."
Exit Sub
Else
Sheets("Client").Range("E" & iRow).Value = [Now()]
Sheets("Client").Range("E" & iRow).NumberFormat = "hh:mm:ss AM/PM"
Sheets("Client").Range("F" & iRow).Value = Sheets("Client").Range("E" & iRow).Value - Sheets("Client").Range("D" & iRow).Value
Sheets("Client").Range("F" & iRow).NumberFormat = "hh:mm:ss"
End If
Call Intialize
End Sub
Well, since you said:
1 Need to copy a single Sheet
2 Apply a code to that sheet, whatever the name
3 You will create (copy) several sheet.
Here is my code.
(Paste everything in a normal module)
Option Explicit
Const A = 1
Const B = 2
Const D = 4
Const E = 5
Const F = 6
Const L = 1048576 'Excel.Application.Rows.Count
'With this you can check if you can copy the sheet
'and also, return that sheet you already checked,
'no matter the name of that sheet.
Private Function SetSheet(sht As Worksheet) As Worksheet
'This function validate if the sheet is one that you need to copy
'Assuming the first sheets of the book are used to:
'
'Parameters 1
'Main 2
'Other... 3
If sht.Index >= 4 Then 'Here is where (Sheet #4 and so on) begins...
Set SetSheet = sht
Else
'Message or do nothing...
End
End If
End Function
Sub Intialize()
' You can uncomment this DIM vars but
' need to comment the const above.
' Dim F: F = Range("F1").Column
' Dim D: D = Range("D1").Column
' Dim A: A = Range("A1").Column
' Dim L: L = Application.Rows.Count
Dim ActSht As Worksheet: Set ActSht = SetSheet(ActiveSheet)
Dim iRow As Long
iRow = ActSht.Range(Cells(L, F), Cells(L, F)).End(xlUp).Row
' Code to Validate
If ActSht.Range(Cells(iRow, D), Cells(iRow, D)).Value = "" Then
ActSht.Range(Cells(iRow, A), Cells(iRow, A)).Value = Format([Today()], "DD-MMM-YYYY")
End If
End Sub
Sub Start_Time()
' Dim B: B = Range("B1").Column
' Dim F: F = Range("F1").Column
' Dim D: D = Range("D1").Column
' Dim L: L = Application.Rows.Count
Dim ActSht As Worksheet: Set ActSht = SetSheet(ActiveSheet)
Dim iRow As Long
iRow = ActSht.Range(Cells(L, F), Cells(L, F)).End(xlUp).Row + 1
' Code to Validate
If ActSht.Range(Cells(iRow, B), Cells(iRow, B)).Value = "" Then
MsgBox "Please select the Task Name from the drop down.", vbOKOnly + vbInformation, "Task Name Blank"
ActSht.Range(Cells(iRow, B), Cells(iRow, B)).Select
Exit Sub
ElseIf ActSht.Range(Cells(iRow, D), Cells(iRow, D)).Value <> "" Then
MsgBox "Start Time is aleady captured for the selected Task."
Exit Sub
Else
ActSht.Range(Cells(iRow, D), Cells(iRow, D)).Value = [Now()]
ActSht.Range(Cells(iRow, D), Cells(iRow, D)).NumberFormat = "hh:mm:ss AM/PM"
End If
End Sub
Sub End_Time()
' Dim D: D = Range("D1").Column
' Dim F: F = Range("F1").Column
' Dim E: E = Range("E1").Column
' Dim L: L = Application.Rows.Count
Dim ActSht As Worksheet: Set ActSht = SetSheet(ActiveSheet)
Dim iRow As Long
iRow = ActSht.Range(Cells(L, F), Cells(L, F)).End(xlUp).Row + 1
' Code to Validate
If ActSht.Range(Cells(iRow, D), Cells(iRow, D)).Value = "" Then
MsgBox "Start Time has not been captured for this task."
Exit Sub
Else
ActSht.Range(Cells(iRow, E), Cells(iRow, E)).Value = [Now()]
ActSht.Range(Cells(iRow, E), Cells(iRow, E)).NumberFormat = "hh:mm:ss AM/PM"
ActSht.Range(Cells(iRow, F), Cells(iRow, F)).Value = Sheets("Client").Range("E" & iRow).Value - Sheets("Client").Range("D" & iRow).Value
ActSht.Range(Cells(iRow, F), Cells(iRow, F)).NumberFormat = "hh:mm:ss"
End If
Call Intialize
End Sub
Asummtions:
1 You call one or several of this sub-rutines from the original worksheet.
Note:
It is better not to use hardcoded this way Sheets("Client").Range("D" & iRow).Value because when you need to debug... It hurts! That is why I do prefer ActSht.Range(Cells(iRow, D), Cells(iRow, D)).Value and you can control a single var above all the code.
this is a continuation of my previous question...
I'm trying to create a user form that will go through a list on a worksheet (TESTER). The form should display the first row of data from the list. User will also be able to select one of two options Active or ITW. Finally, the user is free to add additional comments.
This is where I'm running into trouble, once the user clicks Add, the values from the form should populate the next blank row in a separate sheet (pasteHere). I have no issues with the form displaying the next line of data on the list, but I don't know how to create a loop that will allow me to find the next blank row after clicking the add button. At the moment, I've only initialized j as 1. And every time I click add, it will paste on the first row in the pasteHere worksheet.
Sub addBtn_Click()
Application.ScreenUpdating = False
Dim pasteSheet As Worksheet
Dim j As Long
j = 1 'how can I loop this part
Set pasteSheet = Application.Worksheets("pasteHere")
pasteSheet.Cells(j, j) = ric
pasteSheet.Cells(j, j + 2) = name
pasteSheet.Cells(j, j + 4) = valueUSD
pasteSheet.Cells(j + 1, j) = dstr
i = i + 1
j = j + 2
UserForm1_Initialize
End Sub
Would appreciate any help here. Full code below:
Public valueUSD, name, ric, dstr, sitchStr, pStr As String
Public i, lRow As Long
Sub UserForm1_Initialize()
If Worksheets("pasteHere").Range("A1") = "" Then
i = 2
End If
activeCheck.Value = False
itwCheck.Value = False
TextBox2.Value = ""
ric = Worksheets("Tester").Range("H" & i)
name = Worksheets("Tester").Range("B" & i)
valueUSD = Worksheets("Tester").Range("C" & i)
sitchStr = ""
dstr = ""
pStr = ric & " " & name & " " & valueUSD & " "
UserForm1.Label1.Caption = pStr
End Sub
Sub activeCheck_Change()
If activeCheck.Value = True Then
sitchStr = sitchStr + activeCheck.Caption
Else
sitchStr = ""
End If
End Sub
Sub itwCheck_Change()
If activeCheck.Value = False And itwCheck.Value = True Then
sitchStr = sitchStr + itwCheck.Caption
ElseIf activeCheck.Value = True And itwCheck.Value = True Then
MsgBox ("You can only be active OR ITW")
End If
End Sub
Sub TextBox2_Change()
dstr = sitchStr & ", " & TextBox2.Value
End Sub
Sub addBtn_Click()
Application.ScreenUpdating = False
Dim pasteSheet As Worksheet
Dim j As Long
j = 1 'how can I loop this part
Set pasteSheet = Application.Worksheets("pasteHere")
pasteSheet.Cells(j, j) = ric
pasteSheet.Cells(j, j + 2) = name
pasteSheet.Cells(j, j + 4) = valueUSD
pasteSheet.Cells(j + 1, j) = dstr
i = i + 1
j = j + 2
UserForm1_Initialize
End Sub
Sub skipBtn_Click()
i = i + 1
UserForm1_Initialize
End Sub
Sub exitBtn_Click()
Unload Me
End Sub
I have a Userform with a listbox for which I am using conditional logic to determine output values to the sheet of selected or non-selected items in the listbox. The issue is that when the Textbox (Tbl_AliasName) is blank, the code executes this:
ElseIf .Selected(k) = True And Tbl_AliasName = vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Trim(Cells(2, 1).Value2) & "." & .Column(1, k)
But if Tbl_AliasName is not blank then the code does nothing, but it is supposed to do this:
ElseIf .Selected(k) = True And Tbl_AliasName <> vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Tbl_AliasName & "." & .Column(1, k)
I have used several variations of If statements, and non of which have worked.
Below is My Code:
Option Explicit
Public Tbl_AliasName As String
Tbl_AliasName = Trim(UserForm_Finder.txtConcat.Value)
Private Sub BtnConcat_Click()
Dim k As Long, lstbxRow As Long, LR As Long
lstbxRow = 1
'****************
'This if statement works perfectly
If (Cells(2, 1).Value2 = vbNullString Or Cells(2, 2).Value2 = vbNullString) _
And Tbl_AliasName = vbNullString Then
MsgBox "You must Search for a Table or Column first.", _
vbExclamation, "Error Encountered"
Exit Sub
ElseIf (UserForm_Finder.ListBx_TblsCols.ListCount = 0 And Tbl_AliasName <> vbNullString) Then
MsgBox "You must Search for a Table or Column first.", _
vbExclamation, "Error Encountered"
'(Cells(2, 1).Value2 = vbNullString Or Cells(2, 2).Value2 = vbNullString) And _
Exit Sub
End If
With UserForm_Finder.ListBx_TblsCols
For k = 0 To .ListCount - 1
'****************
This is where the problems begin
If .Selected(k) = False Then
MsgBox "You must Select 1 or more items from the list box.", _
vbExclamation, "Error Encountered"
Exit Sub
ElseIf .Selected(k) = True And Tbl_AliasName <> vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Tbl_AliasName & "." & .Column(1, k)
ElseIf .Selected(k) = True And Tbl_AliasName = vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Trim(Cells(2, 1).Value2) & "." & .Column(1, k)
End If
Next k
End With
End Sub
My goal is to do the following:
If a Textbox (Tbl_AliasName) is not blank and the user has selected one or more items in the listbox (ListBx_TbleCols) then concatenate the Tbl_AliasName to the selected items in the listbox
If Tbl_AliasName is blank, then use the value in Cells(2,1) to concatenate to the selected Items in the list box.
I have tried the following additions:
Dim LstBxItemSelected As Boolean
'This was placed in the for loop
LstBxItemSelected = True
'this was placed outside the for loop
If LstBxItemSelected = False Then
MsgBox "You must Select 1 or more items from the list box.", _
vbExclamation, "Error Encountered"
Exit Sub
End If
Is there a better way to tell if items are selected, because I feel that the way I have it structured in my loop, the code will throw the error if everything isn't selected? Thank you in advance for any ideas, answers, or suggestions!
Note: The Listbox is populated by the click of another button on the userform which calls the following sub:
Sub FillLstBxCols()
Dim ListBx_Target As MSForms.ListBox
Dim rngSource As Range
Dim LR As Long
If Cells(2, 1).Value2 <> vbNullString Then
LR = Worksheets("New TRAX").Cells(Rows.Count, 2).End(xlUp).Row
'Set reference to the range of data to be filled
Set rngSource = Worksheets("New Trax").Range("A" & 2 & ":" & "B" & LR)
'Fill the listbox
Set ListBx_Target = UserForm_Finder.ListBx_TblsCols
With ListBx_Target
.RowSource = rngSource.Address
End With
End If
End Sub
Hard to say without sample data and expected results, but I think this is what you're looking for:
Private Sub btnConcat_Click()
Dim ws As Worksheet
Dim bSelected As Boolean
Dim sConcat As String
Dim i As Long, lRowIndex As Long
Set ws = ActiveWorkbook.Sheets("New TRAX")
lRowIndex = 1
bSelected = False
sConcat = Trim(Me.txtConcat.Text)
If Len(sConcat) = 0 Then sConcat = Trim(ws.Cells(2, "A").Value)
If Len(sConcat) = 0 Then
MsgBox "You must Search for a Table or Column first.", vbExclamation, "Error Encountered"
Exit Sub
End If
For i = 0 To Me.ListBx_TblsCols.ListCount - 1
If Me.ListBx_TblsCols.Selected(i) Then
If bSelected = False Then
bSelected = True
ws.Range("C2", ws.Cells(ws.Rows.Count, "C")).Clear 'clear previous concat results (delete this line if not needed)
End If
lRowIndex = lRowIndex + 1
ws.Cells(lRowIndex, "C").Value = sConcat & "." & Me.ListBx_TblsCols.List(i)
End If
Next i
If bSelected = False Then MsgBox "Must select at least one item from the list"
End Sub
I am writing a macro to download a text file into Excel, filter out unnecessary data and save the modified text file locally.
Everything works but the file that is written locally has quotes (") around certain text. I assume this has something to do with the commas being seen as delimiters, possibly. Is this the case, and if so is there a work around with my code below?
Note: I have a button that runs the GetHtmlTable and KillLoop procedures.
Option Explicit
Public StopLoop As Boolean
Sub GetHtmlTable()
StopLoop = False
Do Until StopLoop = True
DoEvents
Dim objWeb As QueryTable
Sheets(1).Columns(1).ClearContents
With Sheets("Sheet1")
Set objWeb = .QueryTables.Add( _
Connection:="URL;http://www.spotternetwork.org/feeds/gr.txt", _
Destination:=.Range("A1"))
With objWeb
.WebSelectionType = xlSpecifiedTables
.WebTables = "1" ' Identify your HTML Table here
.Refresh BackgroundQuery:=False
.SaveData = True
End With
End With
Set objWeb = Nothing
'End Import of Text From http://www.spotternetwork.org/feeds/gr.txt==================
'Start Filter Out Unused Data========================================================
Dim i As Long
Dim j As Long
Dim LRow As Long
Dim LListRow As Long
Dim BMatch As Boolean
'Find last instance of "End:" in
LRow = Sheets(1).Range("A:A").Find(what:="End*", searchdirection:=xlPrevious).Row
'Find last non-blank row in column A of second sheet
LListRow = Sheets(2).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
If LRow >= 11 Then
'Make sure there are at least 11 rows of data
i = LRow
'MsgBox "First checkpoint: Last row of data is " & LRow 'Comment out this line
Do
BMatch = False
For j = 1 To LListRow
'Test this block to see if the value from j appears in the second row of data
If InStr(1, Sheets(1).Range("A" & i - 2).Value2, Sheets(2).Range("A" & j).Value2) > 0 Then
BMatch = True
Exit For
End If
Next j
'Application.StatusBar = "Match status for row " & i & ": " & BMatch
If Not BMatch Then
'Loop backwards to find the starting row (no lower than 11)
For j = i To 11 Step -1
If Sheets(1).Range("A" & j).Value2 Like "Object:*" Then Exit For
Next j
Sheets(1).Rows(j & ":" & i).Delete
i = j - 1
Else
'Find next block
If i > 11 Then
For j = i - 1 To 11 Step -1
If Sheets(1).Range("A" & j).Value2 Like "End:*" Then Exit For
Next j
i = j
Else
i = 10 'Force the loop to exit
End If
End If
'Application.StatusBar = "Moving to row " & i
Loop Until i < 11
'Loop back through and delete any blank rows
LRow = Sheets(1).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
'MsgBox "Second checkpoint: new last row of data is " & LRow
For i = LRow To 11 Step -1
If Sheets(1).Range("A" & i).Value2 = vbNullString Then Sheets(1).Rows(i).Delete
Next i
End If
'Application.StatusBar = False
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'End Filter Out Unused Data========================================================
'Start Write To Local Txt File=====================================================
Dim sSaveAsFilePath As String
Application.DisplayAlerts = False
sSaveAsFilePath = "C:\Users\Speedy\Desktop\Test\test.txt"
Sheets(1).Copy '//Copy sheet 1 to new workbook
ActiveWorkbook.SaveAs sSaveAsFilePath, xlTextWindows '//Save as text (tab delimited) file
If ActiveWorkbook.Name <> ThisWorkbook.Name Then '//Double sure we don't close this workbook
ActiveWorkbook.Close False
End If
Application.DisplayAlerts = True
Application.Wait (Now + TimeValue("0:00:05"))
Loop
End Sub
Sub KillMacro()
StopLoop = True ' stop that perpetual loop in Workbook_Open()
MsgBox "Program Stopped"
End Sub
Your best bet here will be to write the data to a text file using VBA instead of saving the workbook as a text file.
Consider the below modified code:
Option Explicit
Public StopLoop As Boolean
Sub GetHtmlTable()
StopLoop = False
Do Until StopLoop = True
DoEvents
Dim objWeb As QueryTable
Sheets(1).Columns(1).ClearContents
With Sheets("Sheet1")
Set objWeb = .QueryTables.Add( _
Connection:="URL;http://www.spotternetwork.org/feeds/gr.txt", _
Destination:=.Range("A1"))
With objWeb
.WebSelectionType = xlSpecifiedTables
.WebTables = "1" ' Identify your HTML Table here
.Refresh BackgroundQuery:=False
.SaveData = True
End With
End With
Set objWeb = Nothing
'End Import of Text From http://www.spotternetwork.org/feeds/gr.txt==================
'Start Filter Out Unused Data========================================================
Dim i As Long
Dim j As Long
Dim LRow As Long
Dim LListRow As Long
Dim BMatch As Boolean
'Find last instance of "End:" in
LRow = Sheets(1).Range("A:A").Find(what:="End*", searchdirection:=xlPrevious).Row
'Find last non-blank row in column A of second sheet
LListRow = Sheets(2).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
If LRow >= 11 Then
'Make sure there are at least 11 rows of data
i = LRow
'MsgBox "First checkpoint: Last row of data is " & LRow 'Comment out this line
Do
BMatch = False
For j = 1 To LListRow
'Test this block to see if the value from j appears in the second row of data
If InStr(1, Sheets(1).Range("A" & i - 2).Value2, Sheets(2).Range("A" & j).Value2) > 0 Then
BMatch = True
Exit For
End If
Next j
'Application.StatusBar = "Match status for row " & i & ": " & BMatch
If Not BMatch Then
'Loop backwards to find the starting row (no lower than 11)
For j = i To 11 Step -1
If Sheets(1).Range("A" & j).Value2 Like "Object:*" Then Exit For
Next j
Sheets(1).Rows(j & ":" & i).Delete
i = j - 1
Else
'Find next block
If i > 11 Then
For j = i - 1 To 11 Step -1
If Sheets(1).Range("A" & j).Value2 Like "End:*" Then Exit For
Next j
i = j
Else
i = 10 'Force the loop to exit
End If
End If
'Application.StatusBar = "Moving to row " & i
Loop Until i < 11
'Loop back through and delete any blank rows
LRow = Sheets(1).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
'MsgBox "Second checkpoint: new last row of data is " & LRow
For i = LRow To 11 Step -1
If Sheets(1).Range("A" & i).Value2 = vbNullString Then Sheets(1).Rows(i).Delete
Next i
End If
'Application.StatusBar = False
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'End Filter Out Unused Data========================================================
'Start Write To Local Txt File=====================================================
Dim sSaveAsFilePath As String
Application.DisplayAlerts = False
sSaveAsFilePath = "C:\Users\Speedy\Desktop\Test\test.txt"
'Delete file if it exists
On Error Resume Next
Kill sSaveAsFilePath
On Error GoTo 0
'Open file for writing
LRow = Sheets(1).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
Dim iFile As Integer
iFile = FreeFile()
Open sSaveAsFilePath For Output As #iFile
For i = 1 To LRow
Print #iFile, Sheets(1).Range("A" & i).Value2
Next i
Close #iFile
Application.DisplayAlerts = True
Application.Wait (Now + TimeValue("0:00:05")) 'Uncomment this line
Loop
End Sub
Sub KillMacro()
StopLoop = True ' stop that perpetual loop in Workbook_Open()
MsgBox "Program Stopped"
End Sub