I am developing a user form as you can see below
enter image description here
the code in the Browse Button is
Private Sub Browse_Click()
Dim fName As String
fName = Application.GetOpenFilename("CSV File (*.csv), *.csv", , "Import .CSV File", , False)
If Not fName = "False" Then
TextBox1.Value = fName
End If
End Sub
Next step is to choose some of these options and the code behind it is
Private Sub Start_Click()
Dim Actsheet As String
Dim wkbCrntWorkBook As Workbook
Dim wkbSourceBook As Workbook
Dim rngSourceRange As Range
Dim rngDestination As Range
Set wkbCrntWorkBook = ActiveWorkbook
Set rngDestination = wkbCrntWorkBook.ActiveSheet.Range("A1:A1")
If myBeforeImprovements = True Then
Actsheet = "Before "
ElseIf AfterImprovements = True Then
Actsheet = "After "
Else
MsgBox ("Select Type of Analysis")
Exit Sub
End If
If Westbound = True Then
Actsheet = Actsheet & "WB"
ElseIf Northbound = True Then
Actsheet = Actsheet & "NB"
ElseIf Eastbound = True Then
Actsheet = Actsheet & "EB"
ElseIf Southbound = True Then
Actsheet = Actsheet & "SB"
Else
MsgBox ("Select Traffic Bound")
Exit Sub
End If
my problem is I can't take the CSV file to its write sheet which are
Before EB
Before WB
Before NB
Before SB
After EB
After WB
After NB
After SB
maybe the following code will refer to the selected CSV file but it gives me an error
Workbooks.OpenText Filename:=TextBox1.Text + "," + ComboBox1.Value + ".txt", _
DataType:=xlDelimited, Tab:=True
Replace + with & and it'll hopefully work better. The concatenation operator is & in VBA
Related
Right now I have 8 different textbox controls on a UserForm that when a value is entered a macro runs to open a workbook saved on a network folder then a VLookup is run. Below is the code for two of the TextBox controls and as you can see (due to my lack of coding ability); I ended up with 8 separate subs for each of the text boxes which opens up the workbook on the shared drive after a value is entered in the text box then closes the workbook and is not very efficient. After some research I am thinking of using Index and Match would be a better solution, but have no familiarity with those excel functions in VBA and could use some help with getting a starting point using Index and Match, if that is a better solution. Thank you all for your assistance.
Sub b1CIF()
Dim CustList As Workbook
Dim thisWB As Workbook
Dim thisWS As Worksheet
Dim wsRR As Worksheet
Dim bColor As Range
Dim Msg, Style, Title, Response
Msg = "OOOPS!" & vbNewLine & vbNewLine & "The CIF Number of " & LendStart.lsPBCIF.Value & " " & "is not correct or does not exist." & vbNewLine & "Please re-enter the CIF Number."
Style = vbOKCancel + vbCritical
Title = UCase("***CIF Data Entry Error!***")
Application.ScreenUpdating = False
Set CustList = Workbooks.Open("L:\Deposits\Information\Customers.xlsm")
Set thisWB = ThisWorkbook
Set thisWS = thisWB.Sheets("SavedInfo")
Set wsRR = thisWB.Sheets("RiskRating")
Set bColor = wsRR.Range("C3")
On Error GoTo ErrHandler
' NAME GRAB
If thisWS.Range("A2") <> "" Then
thisWS.Range("PBName").Value = _
WorksheetFunction.VLookup(thisWS.Range("A2").Value, CustList.Sheets("CIFMAST").Range("A1:Z50000"), 2, False)
With LendStart.lsPBName
.Value = thisWS.Range("PBName")
.Visible = True
.Locked = True
.BackColor = bColor.Interior.Color
.Font.Bold = True
.Font.Size = 9
.TextAlign = fmTextAlignCenter
.TabStop = False
End With
thisWB.Sheets("BorrInfo").Range("PB").Value = thisWS.Range("PBName")
' TELEPHONE NUMBER GRAB
thisWB.Sheets("BorrInfo").Range("PBPhone").Value = _
WorksheetFunction.VLookup(thisWS.Range("A2").Value, CustList.Sheets("CIFMAST").Range("A1:Z50000"), 9, False)
End If
CustList.Close
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
LendStart.lsPBSCIF.Value = ""
With LendStart.lsPBName
.Value = ""
.Locked = True
End With
Response = MsgBox(Msg, Style, Title)
CustList.Close
Application.ScreenUpdating = True
End Sub
Sub b2CIF()
Dim CustList As Workbook
Dim thisWB As Workbook
Dim thisWS As Worksheet
Dim wsRR As Worksheet
Dim bColor As Range
Dim Msg, Style, Title, Response
Msg = "The CIF Number entered " & LendStart.lsPBSCIF.Value & " " & "is not correct." & vbNewLine & "Please re-enter the CIF Number."
Style = vbOKCancel + vbCritical
Title = UCase("***CIF data entry error!***")
Application.ScreenUpdating = False
Set CustList = Workbooks.Open("L:\Deposits\Information\Customers.xlsm")
Set thisWB = ThisWorkbook
Set thisWS = thisWB.Sheets("SavedInfo")
Set wsRR = thisWB.Sheets("RiskRating")
Set bColor = wsRR.Range("C3")
On Error GoTo ErrHandler
' NAME GRAB
If thisWS.Range("A3") <> "" Then
thisWS.Range("PBSName").Value = _
WorksheetFunction.VLookup(thisWS.Range("A3").Value, CustList.Sheets("CIFMAST").Range("A1:Z50000"), 2, False)
With LendStart.lsPBSName
.Value = thisWS.Range("PBSName")
.Visible = True
.Locked = True
.BackColor = bColor.Interior.Color
.Font.Bold = True
.Font.Size = 9
.TextAlign = fmTextAlignCenter
.TabStop = False
End With
thisWB.Sheets("BorrInfo").Range("PBS").Value = thisWS.Range("PBSName")
' TELEPHONE NUMBER GRAB
thisWB.Sheets("BorrInfo").Range("PBSPhone").Value = _
WorksheetFunction.VLookup(thisWS.Range("A3").Value, CustList.Sheets("CIFMAST").Range("A1:Z50000"), 9, False)
End If
CustList.Close
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
LendStart.lsPBSCIF.Value = ""
Response = MsgBox(Msg, Style, Title)
CustList.Close
Application.ScreenUpdating = True
End Sub
I found a resource to find specific strings at the following link: https://www.excel-easy.com/vba/examples/read-data-from-text-file.html
How could I apply this to all the .txt files in a folder?
Sub READLINES()
Dim myFile As String, text As String, textline As String, posFood As Integer
'myFile = "C\FOLDER\TEST.txt"
myFile = Application.GetOpenFilename()
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
posFood = InStr(text, "BACON")
Range("A1").Value = Mid(text, posFood + 7, 3) 'should return YUM
End Sub
I think your best bet is to import all data from all text files, into one single sheet, and then filter for the strings you want to find, and copy/paste those to another sheet.
Try the script below to import all data from all files.
Sub ImportCSVsWithReference()
'UpdatebyKutoolsforExcel20151214
Dim xSht As Worksheet
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Set xSht = ThisWorkbook.ActiveSheet
If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.txt")
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
Columns(1).Insert xlShiftToRight
Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close False
xFile = Dir
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "no files csv", , "Kutools for Excel"
End Sub
Then, run this.
Sub MoveData()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim Rng As Range
Set Rng = Range([A1], Range("A" & Rows.Count).End(xlUp))
On Error Resume Next
With Rng
.AutoFilter , field:=1, Criteria1:="Book1"
.SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Sheet2").Range("A1")
.AutoFilter
End With
Application.EnableEvents = True
End Sub
First, let me brief scenario. I want to Import specific CSV file from the user-provided location. I am able to Import it with Fix file name.
Now, I want to Import a CSV file which changing one file name each time.
E.g.
Newdata_Files_LMBN_124587
Newdata_Files_LMBN_458965
Newdata_Files_LMBN_134654
Newdata_Files_LMBN_894354, etc...
I have written code for it, but it doesn't work
Sub zzandand(Optional opt As String)
Application.ScreenUpdating = False
Dim compd1, compd2 As String
Dim ws As Worksheet
Dim rng As Range
Dim path As Variant
Dim tfr1, tfr2 As String
Set path = UserForm1.TextBox1
compd1 = path & "\" & Newdata_Files_ & "*" & ".csv"
If Dir(compd1, vbDirectory) = vbNullString Then
MsgBox ("The file Newdata_Files(csv) could not be found")
Unload UserForm1
End
Else
Workbooks.Open (compd1)
ActiveSheet.Activate
Sheets.Copy Before:=ThisWorkbook.Sheets(Sheets.Count)
ActiveSheet.Name = "compd2"
tfr1 = ActiveSheet.Range("A1").Value
ActiveSheet.Range("A1").Value = UCase(tfr1)
Workbooks("compd1").Close
End If
Application.ScreenUpdating = True
End Sub
Untested:
Sub zzandand(Optional opt As String)
Dim compd1 As String
Dim ws As Worksheet, wb As Workbook
Dim path As Variant
path = Trim(UserForm1.TextBox1)
If Right(path, 1) <> "\" Then path = path & "\" '<<< ensure trailing "\"
compd1 = Dir(path & "Newdata_Files_*.csv") '<<< any matches?
If Len(compd1) = 0 Then '<<< no need for Dir here....
MsgBox "The file Newdata_Files(csv) could not be found"
Unload UserForm1
Else
Set wb = Workbooks.Open(path & compd1) '<<< use the full path!
wb.Sheets(1).Copy _
Before:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wb.Close False 'close without saving
Set ws = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ws.Name = "compd2"
ws.Range("A1").Value = UCase(ws.Range("A1").Value)
End If
End Sub
Looking to loop the following code through (about) 125 worksheets in an Excel workbook and pull the listed cell values into one database entry log on the 'Database' worksheet'. Right now it is only pulling from one of the tabs . (PO VT-0189). Wondering how to correct.
Private Sub PopulateOrderInfo()
Dim OrderDate As String, PONumber As String, Vendor As String, ShipTo As String, SKU As String
Dim R As Long, LastSKURow As Long, NextDBRow As Long, OFrm As Worksheet, DB As Worksheet
For Each OFrm In ActiveWorkbook.Worksheets
Set OFrm = Worksheets("PO VT-0189")
Set DB = Worksheets("Database")
OrderDate = OFrm.Range("N4")
PONumber = OFrm.Range("N3")
Vendor = OFrm.Range("A13")
ShipTo = OFrm.Range("I13")
POTotal = OFrm.Range("P43")
LastSKURow = OFrm.Range("A38").End(xlUp).Row
For R = 21 To LastSKURow
SKU = OFrm.Range("A" & R).Value
SKUDesc = OFrm.Range("D" & R).Value
SKUQty = OFrm.Range("K" & R).Value
Lntotal = OFrm.Range("M" & R).Value
NextDBRow = DB.Cells(DB.Rows.Count, "A").End(xlUp).Row + 1
DB.Range("A" & NextDBRow).Value = OrderDate
DB.Range("B" & NextDBRow).Value = PONumber
DB.Range("C" & NextDBRow).Value = Vendor
DB.Range("D" & NextDBRow).Value = ShipTo
DB.Range("E" & NextDBRow).Value = SKU
DB.Range("F" & NextDBRow).Value = SKUDesc
DB.Range("G" & NextDBRow).Value = SKUQty
DB.Range("H" & NextDBRow).Value = Lntotal
DB.Range("I" & NextDBRow).Value = POTotal
Next R
Next OFrm
End Sub
I think you can also shorten your code by avoiding the loop and most of the variables seem unnecessary to me.
Private Sub PopulateOrderInfo()
Dim R As Long, LastSKURow As Long, NextDBRow As Long, OFrm As Worksheet, DB As Worksheet
Set DB = Worksheets("Database")
For Each OFrm In ActiveWorkbook.Worksheets
If OFrm.Name <> DB.Name Then
LastSKURow = OFrm.Range("A38").End(xlUp).Row
R = LastSKURow - 21 + 1
NextDBRow = DB.Cells(DB.Rows.Count, "A").End(xlUp).Row + 1
DB.Range("A" & NextDBRow).Resize(R).Value = OFrm.Range("N4")
DB.Range("B" & NextDBRow).Resize(R).Value = OFrm.Range("N3")
DB.Range("C" & NextDBRow).Resize(R).Value = OFrm.Range("A13")
DB.Range("D" & NextDBRow).Resize(R).Value = OFrm.Range("I13")
DB.Range("E" & NextDBRow).Resize(R).Value = OFrm.Range("A21").Resize(R).Value
DB.Range("F" & NextDBRow).Resize(R).Value = OFrm.Range("D21").Resize(R).Value
DB.Range("G" & NextDBRow).Resize(R).Value = OFrm.Range("K21").Resize(R).Value
DB.Range("H" & NextDBRow).Resize(R).Value = OFrm.Range("M21").Resize(R).Value
DB.Range("I" & NextDBRow).Resize(R).Value = OFrm.Range("P43")
End If
Next OFrm
End Sub
Use a for loop and WorkSheets collection like:
For I = 1 to worksheets.count
if worksheets(i).name <> "Database" then
Add your code here
end if
Next i
This loops through every worksheet in your workbook and does what ever you need to all worksheets except the Database.
Using a for each... loop
For Each ws In wb.Worksheets
If ws.name = "Database" Then
'Leave blank to just skip database. Code here if you want something special on database. OR statements can be used to exclude additional sheets
Else
'Code here
End If
Next
I think you described the issue fairly well. Just to confirm, you want to loop through all worksheets in one single workbook, right. Try the script below. Feedback if you have additional questions, concerns, etc. Thanks.
Sub ImportAll()
Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean
Dim lngCount As Long
Dim objExcel As Object, objWorkbook As Object
Dim colWorksheets As Collection
Dim strPathFile as String, strTable as String
Dim strPassword As String
' Establish an EXCEL application object
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set objExcel = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = False
' Replace C:\Filename.xls with the actual path and filename
strPathFile = "C:\Filename.xls"
' Replace tablename with the real name of the table into which
' the data are to be imported
strTable = "tablename"
' Replace passwordtext with the real password;
' if there is no password, replace it with vbNullString constant
' (e.g., strPassword = vbNullString)
strPassword = "passwordtext"
blnReadOnly = True ' open EXCEL file in read-only mode
' Open the EXCEL file and read the worksheet names into a collection
Set colWorksheets = New Collection
Set objWorkbook = objExcel.Workbooks.Open(strPathFile, , blnReadOnly, , _
strPassword)
For lngCount = 1 To objWorkbook.Worksheets.Count
colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
Next lngCount
' Close the EXCEL file without saving the file, and clean up the EXCEL objects
objWorkbook.Close False
Set objWorkbook = Nothing
If blnEXCEL = True Then objExcel.Quit
Set objExcel = Nothing
' Import the data from each worksheet into the table
For lngCount = colWorksheets.Count To 1 Step -1
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$"
Next lngCount
' Delete the collection
Set colWorksheets = Nothing
' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPathFile
End Sub
After much struggle with syntax, I have following code working, but I want to use error checking to determine if file is already open using a string.
(Disclosure: I have copied comparesheets from source that I will link when I find it)
Trying to replace this code
Set wbkA = Workbooks.Open(FileName:=wba)
with
Set wBook = Workbooks(wba) 'run time error subscript out of range
If wBook Is Nothing Then
Set wbkA = Workbooks.Open(FileName:=wba)
End If
But I have syntax problem with the string wba. What is proper way use string here?
Sub RunCompare_WS2()
Dim i As Integer
Dim wba, wbb As String
Dim FileName As Variant
Dim wkbA As Workbook
Dim wkbB As Workbook
Dim wBook As Workbook
wba = "C:\c.xlsm"
wbb = "C:\d.xlsm"
'Set wBook = Workbooks(FileName:=wba) 'compiler error named argument not found
'Set wBook = Workbooks(wba) 'run time error subscript out of range
'If wBook Is Nothing Then
'Set wbkA = Workbooks.Open(FileName:=wba)
'End If
Set wbkA = Workbooks.Open(FileName:=wba)
Set wbkB = Workbooks.Open(FileName:=wbb)
For i = 1 To Application.Sheets.Count
Call compareSheets(wbkA.Sheets(i), wbkB.Sheets(i))
Next i
wbkA.Close SaveChanges:=True
wbkB.Close SaveChanges:=False
MsgBox "Completed...", vbInformation
End Sub
Sub compareSheets(shtSheet1 As Worksheet, shtSheet2 As Worksheet)
Dim mycell As Range
Dim mydiffs As Integer
Dim DifFound As Boolean
DifFound = False
sDestFile = "C:\comp-wb.txt"
DestFileNum = FreeFile()
Open sDestFile For Append As DestFileNum
'For each cell in sheet2 that is not the same in Sheet1, color it lightgreen in first file
For Each mycell In shtSheet1.UsedRange
If Not mycell.Value = shtSheet2.Cells(mycell.Row, mycell.Column).Value Then
If DifFound = False Then
Print #DestFileNum, "Row,Col" & vbTab & vbTab & "A Value" & vbTab & vbTab & "B Value"
DifFound = True
End If
mycell.Interior.Color = 5296274 'LightGreen
Print #DestFileNum, mycell.Row & "," & mycell.Column, mycell.Value, shtSheet2.Cells(mycell.Row, mycell.Column).Value '& vbInformation
mydiffs = mydiffs + 1
End If
Next
Print #DestFileNum, mydiffs & " differences found in " & shtSheet1.Name
Close #DestFileNum
End Sub
You can use On Error Resume Next to ignore any error:
Const d As String = "C:\"
wba = "c.xlsm"
On Error Resume Next
Set wBook = Workbooks(wba)
On Error Goto 0
If wBook Is Nothing Then
Set wbkA = Workbooks.Open(d & wba) 'join string d & wba
End If
This will check to see if you have the file open.
Option Explicit
Function InputOpenChecker(InputFilePath) As Boolean
Dim WB As Workbook
Dim StrFileName As String
Dim GetFileName As String
Dim IsFileOpen As Boolean
InputOpenChecker = False
'Set Full path and name of file to check if already opened.
GetFileName = Dir(InputFilePath)
StrFileName = InputFilePath & GetFileName
IsFileOpen = False
For Each WB In Application.Workbooks
If WB.Name = GetFileName Then
IsFileOpen = True
Exit For
End If
Next WB
If you dont have it open, check to see if someone else does.
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open StrFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
'Set the FileLocked Boolean value to true
FileLocked = True
Err.Clear
End If
And one reason for your error could be the inclusion of "FileName:=" in the Workbooks.Open. Try;
Set wbkA = Workbooks.Open(wba)
Set wbkB = Workbooks.Open(wbb)
Fixed my code and reposting with corrections for clarity.
Note I moved to C:\temp since writing to root C:\ folder should not be used because many work computers have root folder locked for security as my colleague just found out!
Sub RunCompare_WS9() 'compare two WKbooks, all sheets write diff to text file
Dim i As Integer
Dim wba, wbb As String
Dim FileName As Variant
Dim wkbA As Workbook
Dim wkbB As Workbook
Dim wbook1 As Workbook
Dim wbook2 As Workbook
wba = "C:\test\c.xlsm"
wbb = "C:\test\d.xlsm"
On Error Resume Next
Set wbook1 = Workbooks(wba)
On Error GoTo 0
If wbook1 Is Nothing Then
Set wbkA = Workbooks.Open(wba)
End If
On Error Resume Next
Set wbook2 = Workbooks(wbb)
On Error GoTo 0
If wbook2 Is Nothing Then
Set wbkB = Workbooks.Open(wbb)
End If
For i = 1 To Application.Sheets.Count
Call compareSheets(wbkA.Sheets(i), wbkB.Sheets(i))
Next i
wbkA.Close SaveChanges:=True
wbkB.Close SaveChanges:=False
MsgBox "Completed...", vbInformation
End Sub
Sub compareSheets(shtSheet1 As Worksheet, shtSheet2 As Worksheet)
Dim mycell As Range
Dim mydiffs As Integer
Dim DifFound As Boolean
DifFound = False
sDestFile = "C:\Test\comp2-wb.txt"
DestFileNum = FreeFile()
Open sDestFile For Append As DestFileNum
'For each cell in sheet2 that is not the same in Sheet1, color it lightgreen in first file
For Each mycell In shtSheet1.UsedRange
If Not mycell.Value = shtSheet2.Cells(mycell.Row, mycell.Column).Value Then
If DifFound = False Then
Print #DestFileNum, "Row,Col" & vbTab & vbTab & "A Value" & vbTab & vbTab & "B Value"
DifFound = True
End If
mycell.Interior.Color = 5296274 'LightGreen
Print #DestFileNum, mycell.Row & "," & mycell.Column, mycell.Value, shtSheet2.Cells(mycell.Row, mycell.Column).Value '& vbInformation
mydiffs = mydiffs + 1
End If
Next
Print #DestFileNum, mydiffs & " differences found in " & shtSheet1.Name
Close #DestFileNum
End Sub