FilesCheck with multiple filename and turn green color in the cell.
Return at Cell C5
Found = Dir(FolderPath & "\" & "01 - Introduction" & " " & Range("B5") & "_v" & Range("B3") & ".*")
Found1 = Dir(FolderPath & "\" & "02 - Business" & " " & Range("B5") & "_v" & Range("B3") & ".*")
Found2 = Dir(FolderPath & "\" & "04 - Linking" & " " & Range("B5") & "_v" & Range("B3") & ".*")
Found3 = Dir(FolderPath & "\" & "05 - Data" & " " & Range("B5") & "_v" & Range("B3") & ".*")
Found4 = Dir(FolderPath & "\" & "06 - Conclusion" & " " & Range("B5") & "_v" & Range("B3") & ".*")
Found5 = Dir(FolderPath & "\" & "Systems_ABC" & "_v" & Range("B3") & ".*")
If Found <> "" & Found1 <> "" & Found2 <> "" & Found3 <> "" & Found4 <> "" & Found5 <> "" Then
Range("C5").Interior.ColorIndex = 4
Else
Range("C5").Interior.ColorIndex = 3
End If
the code are not working, even I change the filename, the cell still will return green color.
Change this:
If Found <> "" & Found1 <> "" & Found2 <> "" & Found3 <> "" & Found4 <> "" & Found5 <> "" Then
Range("C5").Interior.ColorIndex = 4
Else
Range("C5").Interior.ColorIndex = 3
End If
With This:
If Found <> "" And Found1 <> "" And Found2 <> "" And Found3 <> "" And Found4 <> "" And Found5 <> "" Then
Range("C5").Interior.ColorIndex = 4
Else
Range("C5").Interior.ColorIndex = 3
End If
And is accepted like this. Also I am assuming that your DIR are all working fine.
Related
I want to write a code in Vba that when I click a button in Excel data, then in Tableau the fields are filled according to my Excel data and then the final filtered file is downloaded from Tableau. I have written this code but I get an empty Excel:
Sub GetSizeDataFromTableau(Optional strType As String = "")
Dim strLink As String
Dim wshshell As Object
With ThisWorkbook.Worksheets("Ordersheet")
If .Cells(1, 4) <> "" And .Cells(2, 4) <> "" And .Cells(2, 3) <> "" And .Cells(4, 43) <> "" Then 'Master Brand / Saison / Categorie 1 / Typ Produkttyp oder Categorie 2
strLink = "http://mymind.mytoys.group/#/views/ArticleSizeDistribution/Articlesizedistribution2" & strType & "?" & _
"&Switch off Target Grp/Gender on/off=on" & _
"&Purchase Department=PMM" & _
"&End Order Date (Transaction)=" & Year(Date) & "-" & Month(Date) & "-" & Day(Date) & _
"&order quantity=100" & _
"&Parameter.Category 1=" & .Cells(2, 3) & _
"&Parameter.Master Brand=" & .Cells(1, 4)
'Size data level
If UCase(.Cells(4, 43)) = "PT" Then
strLink = strLink & "&Switch between Dimensions=Product Type"
Else
strLink = strLink & "&Switch between Dimensions=Category 2"
End If
'Start Order Date
If Left(.Cells(2, 4), 2) = "FS" Then
strLink = strLink & "&Start Order Date (Transaction)=" & "20" & Right(.Cells(2, 4), 2) - 1 & "-01-01"
Else
strLink = strLink & "&Start Order Date (Transaction)=" & "20" & Right(.Cells(2, 4), 2) - 1 & "-07-01"
End If
'Supplier
If .Cells(1, 3) <> "" Then
strLink = strLink & "&Parameter.Primary Supplier=" & .Cells(1, 3)
End If
strLink = Replace(strLink, " ", "%20")
Set wshshell = CreateObject("WScript.Shell")
wshshell.Run strLink
If strType <> "" Then
.OLEObjects("cmdGetSizeData").Object.BackColor = RGB(0, 255, 0)
End If
Else
MsgBox "the following fields must be specified so that the size distribution data can be pulled from Tableau:" & vbNewLine & _
" - Size data level" & vbNewLine & _
" - Saison" & vbNewLine & _
" - Category 1" & vbNewLine & _
" - Marke" & vbNewLine & _
" Optional: Supplier"
End If
End With
End Sub
My code renames folders based on what is in first column:
Dim sFolder As String
Option Explicit
Sub addPrefix()
Dim strfile As String
Dim filenum As String
Dim strOldDirName
Dim strNewDirName
strfile = Dir(sFolder)
Dim old_name, new_name As String
Dim i As Long
With ThisWorkbook.Worksheets("data")
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
strOldDirName = sFolder & ThisWorkbook.Worksheets("data").Cells(i, 2).Value
strNewDirName = sFolder & ThisWorkbook.Worksheets("data").Cells(i, 1).Value & " " & ThisWorkbook.Worksheets("data").Cells(i, 2).Value
Name strOldDirName As strNewDirName
Next i
End With
End Sub
and then I check for duplicates on Column C (email column). If they are a duplicate I move them to their 'master' folder (which is just the first of the duplicates found). Upon this, it adds the suffix ' - MASTER' on to the folder.
Here is the code to move duplicates:
Sub moveDuplicates()
' This will find duplicates and move them into a master folder. It'll will then delete the row
Dim masterID
Dim masterPlatform
Dim objFileSystem
Dim FromPath As String
Dim ToPath As String
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Dim masterOldFolderName
Dim masterNewFolderName
Dim masterSuffix
Dim LastRow As Long, i As Long
Dim rngWhole As Range, rngSplit As Range
masterID = 0
masterPlatform = 0
masterSuffix = " - MASTER"
masterOldFolderName = ""
masterNewFolderName = ""
With ThisWorkbook.Worksheets("data")
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rngWhole = .Range("C1:C" & LastRow)
.Range("E" & 1).Value = rngWhole
For i = 1 To LastRow
If WorksheetFunction.CountIf(rngWhole, .Range("C" & i).Value) > 1 Then
Set rngSplit = .Range("C1:C" & i)
If WorksheetFunction.CountIf(rngSplit, .Range("C" & i).Value) = 1 Then
masterID = .Range("B" & i).Value
masterPlatform = .Range("A" & i).Value
'' Renme master folders with subfix of "- MASTER"
masterOldFolderName = sFolder & masterPlatform & " " & masterID
masterNewFolderName = sFolder & masterPlatform & " " & masterID & masterSuffix
Name masterOldFolderName As masterNewFolderName
'' End of renaming
'.Range("D" & i).Value = "MASTER " & masterID
Else
'.Range("D" & i).Value = "CHILD " & masterID & " This folder: " & .Range("B" & i).Value
'MOVING FOLDER
FromPath = sFolder & .Range("A" & i).Value & " " & .Range("B" & i).Value '<< Change
ToPath = sFolder & masterPlatform & " " & masterID & masterSuffix & "\" '<< needs the slash to go into the folder
.Range("H" & i).Value = "From: " & FromPath
.Range("I" & i).Value = "From: " & ToPath
'Check if source and target folder exists
If objFileSystem.FolderExists(FromPath) = True And objFileSystem.FolderExists(ToPath) = True Then
objFileSystem.MoveFolder Source:=FromPath, Destination:=ToPath
lblStatus.Caption = "Moving " & FromPath & " To " & ToPath
Rows(i).EntireRow.Delete
lblStatus.Caption = " Deleting " & .Range("A" & i).Value & " " & .Range("B" & i).Value
'MsgBox "Source folder has moved to target folder"
Else
'MsgBox "Either source or target folder does not exist"
End If
' END OF MOVING FOLDER
' ROW GETS DELETED
End If
'.Range("C" & i).Interior.ColorIndex = 3
End If
Next i
End With
End Sub
My script works to a certain degree:
But it just puts everything into the first 'MASTER' folder
Here is my sheet:
I then call this from a button:
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1) & "\"
End If
End With
If sFolder <> "" Then ' if a file was chosen
Me.txtFolderPath.Text = sFolder
'' calls functions
addPrefix
moveDuplicates
Sheet_SaveAs ' saves output
end sub
Is the reason it is not performing as expected due to I am calling it wrongly?
Full code: https://www.dropbox.com/s/k06b5hydc4v7bpn/so-files.zip?dl=0
(code can be run from developer> forms> userform1)
DEBUGGING:
I think the problem seems to arise here when debugging:
'' Renme master folders with subfix of "- MASTER"
masterOldFolderName = sFolder & masterPlatform & " " & masterID
masterNewFolderName = sFolder & masterPlatform & " " & masterID & masterSuffix
Name masterOldFolderName As masterNewFolderName
'' End of renaming
I am not sure if this is because it is in the wrong place (which I assume)
Very new to VBA and trying to create an automated textfile export.
Currently it works like a charm for row 1 and the textfile is created. But when adding data on row 2 as well I get:
Runtime error 91, Object variable or With block variable not set.
Any help would be much appreciated!
Sub Exportera()
Dim bKlar As Boolean
Dim bSkrivPSlut As Boolean
Dim bSkrivPStart As Boolean
Dim fsoExpFil As FileSystemObject
Dim fsoTextStream2 As TextStream
Dim sExportFile As String
Dim iSvar As Integer
Dim iSvar2 As Integer
Dim sSokvag As String
Dim sFilnamn As String
Dim sTemp As String
Dim sPFalt As String
Dim cVarde As Currency
Dim sDatum As String
'alright då skapar vi fil och skriver till den
Set fsoExpFil = New FileSystemObject
Range("K10").Select
sSokvag = Trim(ActiveCell.FormulaR1C1)
Range("K13").Select
sFilnamn = Trim(ActiveCell.FormulaR1C1)
If Not UCase(Right(sFilnamn, 4)) = ".TXT" Then
sFilnamn = sFilnamn & ".txt"
End If
sExportFile = sSokvag & "\" & sFilnamn
If sSokvag = "" Or sFilnamn = "" Then
MsgBox "Exporten avbryts då sökväg och filnamn saknas för exportfilen.", vbInformation, sAppName
Exit Sub
Else
If fsoExpFil.FileExists(sExportFile) = True Then
iSvar = MsgBox("Filen " & sFilnamn & " finns redan, skall den ersättas?", vbYesNo, sAppName)
If iSvar = vbNo Then
Exit Sub
End If
Else
iSvar = MsgBox("Är du säker att du vill exportera?", vbYesNo, "Exportera")
End If
End If
If iSvar = vbYes Then
Set fsoTextStream2 = fsoExpFil.OpenTextFile(sExportFile, ForWriting, True)
fsoTextStream2.WriteLine "Filhuvud"
fsoTextStream2.WriteLine vbTab & "Typ=" & """Anställda"""
sTemp = "SkapadAv=" & """"
sTemp = sTemp & "Importfil"
sTemp = sTemp & """"
fsoTextStream2.WriteLine vbTab & sTemp
fsoTextStream2.WriteLine vbTab & "DatumTid=" & "#" & Now & "#"
bKlar = False
i = 1
Sheets("Data").Select
While bKlar = False
i = i + 1
Range("A" & i).Select
If Trim(ActiveCell.FormulaR1C1) <> "" Then
If IsNumeric(ActiveCell.FormulaR1C1) Then
fsoTextStream2.WriteLine "PStart"
fsoTextStream2.WriteLine " Typ = ""Anställda"""
Range("A" & i).Select
If Trim(ActiveCell.FormulaR1C1) <> "" Then
fsoTextStream2.WriteLine " Anställningsnummer = " & ActiveCell.FormulaR1C1
End If
Range("B" & i).Select
If Trim(ActiveCell.Text) <> "" Then
fsoTextStream2.WriteLine " Namn=" & Trim(ActiveCell.FormulaR1C1)
End If
Range("D" & i).Select
If Trim(ActiveCell.Text) <> "" Then
fsoTextStream2.WriteLine " Utdelningsadress=" & ActiveCell.FormulaR1C1
End If
Range("E" & i).Select
If Trim(ActiveCell.Text) <> "" Then
fsoTextStream2.WriteLine " co_adress=" & ActiveCell.FormulaR1C1
End If
Range("G" & i).Select
If Trim(ActiveCell.Text) <> "" Then
fsoTextStream2.WriteLine " Postadress=" & ActiveCell.FormulaR1C1
End If
Range("F" & i).Select
If Trim(ActiveCell.Text) <> "" Then
fsoTextStream2.WriteLine " Postnummer=" & ActiveCell.FormulaR1C1
End If
Range("C" & i).Select
If Trim(ActiveCell.Text) <> "" Then
sTemp = ActiveCell.FormulaR1C1
sTemp = Mid(sTemp, 1, 6) & "-" & Mid(sTemp, 7)
fsoTextStream2.WriteLine " Personnummer=" & sTemp
End If
Range("H" & i).Select
If Trim(ActiveCell.Text) <> "" Then
fsoTextStream2.WriteLine " E_mail=" & ActiveCell.FormulaR1C1
End If
Range("I" & i).Select
If Trim(ActiveCell.Text) <> "" Then
sTemp = ActiveCell.FormulaR1C1
Range("AM" & i).Select
sTemp = sTemp & ActiveCell.FormulaR1C1
sTemp = Replace(sTemp, "-", "")
fsoTextStream2.WriteLine " Bankkontonummer=" & sTemp
End If
Range("J" & i).Select
If Trim(ActiveCell.Text) <> "" Then
sDatum = ActiveCell.Text
fsoTextStream2.WriteLine " Anställningsdatum=" & "#" & sDatum & "#"
End If
fsoTextStream2.WriteLine "PSlut"
fsoTextStream2.Close
MsgBox "Exporten är klar", vbInformation, sAppName
End If
Else
bKlar = True
End If
Wend
End If
End Sub
Your problem is not exactly what you'd be expecting.
Note that in your while loop, you close your filestream object at the end with fsoTextStream2.Close. What you'll be seeing is that it will successfully write the first line, but then close the file and then try to write to a file that is closed.
Simply moving this outside the loop (after wend) will fix your problem (Shown below).
fsoTextStream2.WriteLine "PSlut"
MsgBox "Exporten är klar", vbInformation, sAppName
End If
Else
bKlar = True
End If
Wend
fsoTextStream2.Close 'This line has been moved outside the loop
End If
End Sub
There's quite a few improvements for your code, if you alter it slightly to avoid .select calls. Also .value rather than .text might be useful if your cells have numeric input. Note that you can extract cell values without having them selected by using range("A" & i).value (or simply range("A" & i)) using worksheet("sheetname").range("A" & i) to access specific sheet cells. (cells(row, column) works just as well).
I have a master spreadsheet that analyzes records from another spreadsheet with rows going all the way up to 1.4 million.
Below are the relevant pieces from the code:
Sub Whyamidoingthis()
Dim USISINLfp As String
Dim ISINL As String
Dim echeck As String
Dim wUSISIN As Workbook
Dim lastrow As Long
Dim Result As Worksheet
Dim i As Long
Set OutShVar = ThisWorkbook.Worksheets("in1")
ISINL = "CONSOLIDATED - Country_Of_Incorp_US_2019-03-01 (Consolidated).xlsx"
USISINLfp = "W:\Product Platforms\ISIN- CUSIP Country of Incorporation\March 2019\"
Workbooks.Open (USISINLfp & ISINL)
Set wUSISIN = Workbooks(ISINL)
With Result
lastrow = .Cells(.Rows.Count, "H").End(xlUp).Row
End With
'US Security 1
For i = 2 To lastrow
With Result
echeck = Trim(.Range("O" & i))
If echeck = "" Then
.Range("P" & i & ":Q" & i).Value = "N"
Else
.Range("P" & i).Value = "=ifna(vlookup(O" & i & "," & ISINL & "First Sheet'!$B:$C,2,false)," & Chr(34) & "N" & Chr(34) & ")"
.Range("Q" & i).Value = "=ifna(vlookup(O" & i & "," & ISINL & "Second Sheet'!$B:$C,2,false)," & Chr(34) & "N" & Chr(34) & ")"
'Debug.Print "=ifna(vlookup(O" & i & "," & ISINL & "Second Sheet'!$B:$C,2,0)," & Chr(34) & "N" & Chr(34) & ")"
End If
'US Security 2
echeck = Trim(.Range("S" & i))
If echeck = "" Then
.Range("T" & i & ":U" & i).Value = "N"
Else
.Range("T" & i).Value = "=ifna(vlookup(S" & i & "," & ISINL & "First Sheet'!$A:$C,3,false)," & Chr(34) & "N" & Chr(34) & ")"
.Range("U" & i).Value = "=ifna(vlookup(S" & i & "," & ISINL & "Second Sheet'!$A:$C,3,false)," & Chr(34) & "N" & Chr(34) & ")"
End If
End With
Next I
If Not wUSISIN Is Nothing Then wUSISIN.Close savechanges:=False
End Sub
The code is getting stuck at the following line:
.Range("T" & i).Value = "=ifna(vlookup(S" & i & "," & ISINL & "First Sheet'!$A:$C,3,false)," & Chr(34) & "N" & Chr(34) & ")"
Whenever a result is found and the error is application defined error.
Try this formula:
"=ifna(vlookup(O" & i & ",'[" & ISINL & "]First Sheet'!$B:$C,2,false)," & Chr(34) & "N" & Chr(34) & ")"
This places square brackets around the workbook name and single quotes around the workbook-worksheet combo. See this tutorial about using VLOOKUP from another workbook.
I've concatenated a string to paste an index match formula into rows of a column. Every time I try running this piece of code, I get Runtime Error '1004, but I can't see what I have wrong. Here's the code I have:
Dim j As Long
'Loop down the rows in mainfile
For j = 2 To lastFullRow2
Dim firstArgument As String
firstArgument = "Sheet2!" & valuecolumnLetter & "2:" & valuecolumnLetter & lastFullRow1 & ""
'MsgBox "firstArgument" & firstArgument
Dim secondArgument As String
secondArgument = "Sheet2!" & parameter1columnLetter & "2:" & parameter1columnLetter & lastFullRow1 & ""
'MsgBox "secondArgument " & secondArgument
Dim thirdArgument As String
thirdArgument = "Sheet2!" & parameter2columnLetter & "2:" & parameter2columnLetter & lastFullRow1 & ""
'MsgBox "thirdArgument " & thirdArgument
Dim fourthArgument As String
fourthArgument = "Sheet2!" & parameter2columnLetter & "2:" & parameter2columnLetter & lastFullRow1 & ""
'MsgBox "fourthArgument " & fourthArgument
Dim condition3 As String
condition3 = "Sheet3!" & "D2:" & D & j & ""
'MsgBox "condition3 " & condition3
Dim patid1 As String
patid1 = "Sheet2!" & "D2:" & D & lastFullRow2 & ""
'MsgBox "patid1 " & patid1
With ws_mainfile
Dim commandstring As String
commandstring = "=INDEX(" & firstArgument & ",MATCH(1,(" & secondArgument & "=" & condition1 & ")*(" & thirdArgument & "=" & condition2 & ")*(" & patid1 & "=" & condition3 & "),0))"
ws_mainfile.Range("AN" & j).FormulaArray = commandstring
End With
Next j
The debugger is saying the error is at the ws_mainfile.Range... = commandstring line.
condition3 = "Sheet3!" & "D2:" & D & j & ""
patid1 = "Sheet2!" & "D2:" & D & lastFullRow2 & ""
Have you defined a variable D and what is its value?
Maybe you meant:
condition3 = "Sheet3!" & "D2:D" & j
patid1 = "Sheet2!" & "D2:D" & lastFullRow2
There's also no need to concatenate an empty string onto the end of those lines.