I found a piece of vba code that counts the number of xml files in a specific folder, i modified it to only count files with a specific string (located in cell F3) as part of the file name. And print that count in the adjacent cell (cell G3). Its working as expected.
My problem is that I need the results for a entire range. The range of strings are created from a pivot table.
I tried just dublicating the code and modifying the reference cells, and that works. But the range can be from a few strings to 70+, i'm sure that there is a much more efficient and cleaner way than running the code 70+ times.
Dim FolderPath As String, path As String, count As Integer
FolderPath = "C:\Test\PJC"
path = FolderPath & "\*" & Range("F3") & "*.xml"
FileName = Dir(path)
Do While FileName <> ""
count = count + 1
FileName = Dir()
Loop
Range("G3").Value = count
There you have alternatives:
' One line solution, but can count all files only, without wildcards
Debug.Print CreateObject("Scripting.FileSystemObject").GetFolder("C:\temp\").Files.count
' Counting all *.pdf files in C:\temp
FolderPath = "\\temp\\"
Path = "pdf"
Dim objWMIService As Object
Dim objFiles As Object
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set objFiles = objWMIService.ExecQuery("Select * from CIM_DataFile where Path = '" & FolderPath & "' and Extension = '" & Path & "'")
Debug.Print "Files count: ", objFiles.Count
Iterating over a Range can be achieved as follows:
Sub IterateRange()
Dim rng As Range, cell As Range
Dim myWs As Worksheet
Set myWs = Application.Worksheets("sheet1")
Set rng = myWs.Range("A1:A6")
For Each cell In rng
MsgBox cell.Value
Next cell
End Sub
Often iterating might be more straightforward using the .Cells property of a Worksheet, it could look like this:
Sub IterateRange()
Dim i As Long
Dim myWs As Worksheet
Set myWs = Application.Worksheets("Sheet1")
for i=1 to 6
MsgBox myWs.Cells(i, 1)
next i
End Sub
For your example, if you have the strings you want to check for in the Range F3:F73, and the count results should be in the Range G3:G73 the loop you are looking for might look something like this:
Sub Example()
Dim FolderPath As String, path As String, count As Integer, i As Integer
Dim myWs As Worksheet
Set myWs = Application.Worksheets("Sheet1")
For i = 3 To 73
count=0
FolderPath = "C:\Test\PJC"
path = FolderPath & "\*" & myWs.Cells(i, 6) & "*.xml"
Filename = Dir(path)
Do While Filename <> ""
count = count + 1
Filename = Dir()
Loop
myWs.Cells(i, 7) = count
Next i
End Sub
For the loop to stop automatically after the last row of input strings just add
if myWs.Cells(i, 6)="" then
exit for
end if
between the lines For i = 3 To 73 and count=0
Guess this will do the trick.
I took your code and put it in a For loop.
I define the start row as row 3.
EndRange will search for the last value in column F. The For loop will iterate from StartRange to EndRange values.
I also made the count to print the the result from the count variable for each loop in the G column.
Sub LoopRange()
Dim FolderPath As String, path As String, count As Integer
Dim StartRange As Long, EndRange As Long
StartRange = 3 'Row = 3 for start
EndRange = Cells(Rows.count, "F").End(xlUp).Row 'Find last row in column F
For i = StartRange To EndRange 'Loop from start to end value
FolderPath = "C:\Test\PJC"
path = FolderPath & "\*" & Range(Cells(i, "F"), Cells(i, "F")) & "*.xml" 'Take the value from row i and column F in the loop.
Filename = Dir(path)
Do While Filename <> ""
count = count + 1
Filename = Dir()
Loop
Range(Cells(i, "G"), Cells(i, "G")).Value = count 'Print the count
Next i
End Sub
Related
How do we modify program to remove unique values in cell and do not end of string with this value?
We need remove rows
from c3delete.txt file with unique values
first
second etc..
from excel c3 column in excel file***
Sub RemoveRowsRentruck()
Dim sh As Worksheet, N1 As Long, d1 As Long, arrCond, El, txtFileName As String
Dim objFSO As Object, objTxt As Object, rngDel As Range, strText As String
Set sh = ThisWorkbook.ActiveSheet 'use here the necessary sheet (not necessary to be activated)
sh.Cells.ClearFormats
txtFileName = ThisWorkbook.Path & "\" & "c3delete.txt" 'fill here the text file full name
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FileExists(txtFileName) Then 'check if the text file exists in the path
MsgBox "The text file does not exist on the path: """ & txtFileName & """."
Exit Sub
End If
Set objTxt = objFSO.OpenTextFile(txtFileName, 1)
strText = objTxt.ReadAll 'read the text file content
objTxt.Close
arrCond = Split(strText, vbCrLf) 'put it in an array splitting on vbCrLf (end of line)
N1 = Range("C" & Rows.Count).End(xlUp).Row 'last row of the G:G column
For d1 = 1 To N1 'iterate between the existing range
For Each El In arrCond 'check each element of the array keeping conditions
If El <> "" Then
If InStr(1, sh.Cells(d1, 3).Text, El, vbTextCompare) > 0 Then
If rngDel Is Nothing Then 'if the range to be deleted not Set
Set rngDel = sh.Cells(d1, 3)
Else
Set rngDel = Union(rngDel, sh.Cells(d1, 3)) 'if already Set
End If
End If
End If
Next El
Next d1
'delete all the rows at once:
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp
End Sub
--------------------
c3delete.txt file with content
first
second
----------------
excel file a1 b2 c3
five
first
second
seven
first
nine
I have a fairly large excel file (Think 65,000+ rows).
Within the excel file, only two columns matter for this exercise: CCNumber and FileFound (Col BC/BD).
I am trying to use a for loop to loop through the 65,000 + rows and compare the CCNumber (ID) against a folder of files (30,000 files), and then if an id matches/isnt found print "Available" or "Not Found" in the FileFound column - As below:
Sub LoopFiles
Dim fileName As Variant, csheet As Variant
fileName = Dir("Some\Directory\Here\*pdf")
Dim CCNums As Range
Set CCNums = Range("BC4:BC68512")
Application.ScreenUpdating = False
While fileName <> ""
ID = Left(fileName,6) 'id is a 6 digit numeric number, strip away everything else
For Each CCNum in CCNums
csheet = Left(CCNum, 6)
if(ID = csheet) Then
CCNum.Offset(0,1).Value = "Available"
Else
CCNum.Offset(0,1).Value = "Not Found"
End If
Next CCNum
fileName = Dir
Wend
Application.ScreenUpdating = True
End Sub
The above is hilariously inefficient and it takes forever. Is there a way I can speed this up, or am I just going to have to sit here and wait for the spinning wheel of doom to stop.
Instead of looping through a file list you can directly check with Dir and wildcards if a file exists.
eg. you can use Dir("C:\Temp\myNumber*.pdf") to find a file that is named myNumberAndUnusefulText.pdf. So if you use fileName = Dir("Some\Directory\Here\" & CSheet & "*.pdf") it will return the file name of a file that starts with the number in CSheet.
Further reading all the values into an array first and then processing the array makes your code much faster. Reading and writing actions to cells use a lot of overhead and therefore are slow. By reading the values into an array you reduce it to just one cell reading and one cell writing action.
Option Explicit
Public Sub LoopFilesImproved()
Dim CCNums As Range
Set CCNums = ThisWorkbook.Worksheets("Sheet1").Range("BC4:BC68512") ' always specify in which sheet a range is!
' define output range
Dim Output As Range
Set Output = CCNums.Offset(ColumnOffset:=1)
' read output range into array for faster processing
Dim OutputValues() As Variant
OutputValues = Output.Value2
' read all values into an array for faster processing
Dim CCNumsValues() As Variant
CCNumsValues = CCNums.Value2
' loop through numbers and check if a file exists
Dim iCCNum As Long
For iCCNum = LBound(CCNumsValues, 1) To UBound(CCNumsValues, 1)
Dim CSheet As String
CSheet = Left$(CCNumsValues(iCCNum, 1), 6)
Dim fileName As String
fileName = Dir("Some\Directory\Here\" & CSheet & "*.pdf")
If fileName <> vbNullString Then
OutputValues(iCCNum, 1) = "Available"
Else
OutputValues(iCCNum, 1) = "Not Found"
End If
Next iCCNum
' write array values back to cell
Output.Value2 = OutputValues
End Sub
You can try first collecting all of the file names into a dictionary - from that point the check will be fast...
Sub LoopFiles()
Dim dictFiles As Object, arrCC, arrAv, rngCC As Range, r As Long
Set dictFiles = FileIds("Some\Directory\Here\*.pdf") 'collect all the file Id's
Set rngCC = ActiveSheet.Range("BC4:BC68512")
arrCC = rngCC.Value
ReDim arrAv(1 To UBound(arrCC, 1), 1 To 1) 'size the "available?" array
For r = 1 To UBound(arrCC, 1) 'loop data from BC
id = Left(arrCC(r, 1), 6) 'extract the id
arrAv(r, 1) = IIf(dict.exists(id), "Available", "Not found")
Next r
rngCC.Offset(0, 1).Value = arrAv 'populate availability in BD
End Sub
'scan all files matching the `folderPath` pattern, and return a Dictionary object
' with keys equal to the first 6 characters of the file names
Function FileIds(folderPath As String)
Dim dict As Object, f, id
Set dict = CreateObject("scripting.dictionary")
f = Dir(folderPath)
Do While Len(f) > 0
If Len(f) >= 10 Then dict(Left(f, 6)) = True 'need at least 10 chars with the extension
f = Dir()
Loop
Set FileIds = dict
End Function
In a quick test on a local drive with 30k files, calling FileIds took about 0.08 seconds. Calling Dir() 65k times on the same folder took 12-13secs.
Update File Availability Using a List
Option Explicit
Sub UpdateFilesAvailability()
Const FolderPath As String = "C:\Test"
Const RightFilePart As String = "*.pdf"
Const idLen As Long = 6
Const sRangeAddress As String = "BC4:BC68512"
Const dCol As String = "BD"
Const dYes As String = "Available"
Const dNo As String = "Not found"
Const Msg As String = "Files availability updated."
' Validate the folder path.
Dim fPath As String: fPath = FolderPath
If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
If Len(Dir(fPath, vbDirectory)) = 0 Then
MsgBox "The folder '" & fPath & "' doesn't exist.", vbCritical
Exit Sub
End If
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Reference the source range ('srg').
Dim srg As Range: Set srg = ws.Range(sRangeAddress)
' Write the values from the source range
' to a 2D one-based one-column array ('Data').
Dim Data As Variant: Data = srg.Value
Dim cString As String ' Current String
Dim fName As String ' Current File Name
Dim r As Long ' Current Array Row
Dim FileFound As Boolean
' Loop through the rows of the destination array and replace its values
' with the results.
For r = 1 To UBound(Data, 1)
cString = CStr(Data(r, 1))
If Len(cString) >= idLen Then
fName = Dir(fPath & Left(cString, idLen) & RightFilePart)
If Len(fName) > 0 Then FileFound = True
End If
If FileFound Then
Data(r, 1) = dYes
FileFound = False
Else
Data(r, 1) = dNo
End If
Next r
' Reference the destination range.
Dim drg As Range: Set drg = srg.EntireRow.Columns(dCol)
' Write the values from the array to the destination range.
drg.Value = Data
'drg.EntireColumn.AutoFit
'ws.Parent.Save ' save the workbook
MsgBox Msg, vbInformation
End Sub
I have a VBA code that searches a directory for folders based on a partial name.
The partial names are in column F, the code returns the folder name and folder path.
For example, the folder path is "C:\Users\Dunelle\Desktop\10001-Rev1
The last part of the path (Rev1) changes but the 10001 remains unchanged. I need to perform a search using the wildcard 10001*.
The partial names are in column F and I want to return the search with folder name in column A on the same row and return the folder path in column B on the same row when I enter a value in column F.
The code I have written works when a single cell is referenced.
However, I get an error 13 type mismatch error when I change the range to ("F:F").
This is the code I have:
Sub SearchName()
Dim ENumber As Range
Dim ECell As Range
Dim I As Integer
Dim rownumber As Integer
Dim varDirectory As Variant
Dim strDirectory As String
Set ENumber = Range ("F:F")
rownumber = ENumber.Row
strdirectory = "C:\Users\Dunelle\Desktop\" & ENumber & "*"
varDirectory = Dir (strDirectory, vbDirectory)
For Each ECell In ENumber.Cells
If ENumber <> "" Then
Cells(rownumber, 1) = varDirectory
Cells(rownumber, 2) = strDirectory + varDirectory
Exit Function
End If
Next ECell
End Sub
Please help.
Thanks
Try changing the range to a defined one, like this:
Set ENumber = Range("F1:F10")
Or if it's a variable length range:
Set ENumber = Range("F1:F" & Range("F1").End(xlDown).Row)
You can't name an entire range into one string, strDirectory. You must only select a single cell from that range at a time. You just need to move 3 lines into the For loop.
Try this:
Sub SearchName()
Dim ENumber As Range
Dim ECell As Range
Dim I As Integer
Dim rownumber As Integer
Dim varDirectory As Variant
Dim strDirectory As String
Set ENumber = Range ("F:F")
'Move the next 3 lines into the loop and change `Enumber` to `Ecell`
'rownumber = ENumber.Row
'strdirectory = "C:\Users\Dunelle\Desktop\" & ENumber & "*"
'varDirectory = Dir (strDirectory, vbDirectory)
For Each ECell In ENumber.Cells
strDirectory = "C:\Users\Dunelle\Desktop\" & ECell & "*"
varDirectory = Dir(strDirectory, vbDirectory)
rownumber = ECell.Row
If ENumber <> "" Then
Cells(rownumber, 1) = varDirectory
Cells(rownumber, 2) = strDirectory + varDirectory
Exit Function
End If
Next ECell
End Sub
Side note: You have Exit Function in the For loop. It should say Exit Sub.
Beginner in VBA so sorry if the code is bad.
What I wanted to achieve was to search a folder and its sub folders for the .dxf file of a part number listed in Column B, and return either a "Yes" or "No" depending on whether that .dxf file exist in that folder or its sub folders.
What I expected was that the code would begin with the first part number listed in B2, search the folder and sub folders for the .dxf file related, return a value, then move on to the next one, B3 then B4 and so on until the part numbers stop.
What it does is search a folder for all listed part numbers in Column B, returns all values, then searches a subfolder, returns all values (overriding the previous results) and so on until there are no more subfolders to search.
I feel like I'm close to getting the result I want but not sure where I've gone wrong.
Code is below:
Option Explicit
Dim FileSystem As Object
Dim HostFolder As String
Sub FindFile()
HostFolder = "C:\Users\Anyone\DXF\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
Dim SubFolder
Dim Row As Integer
Dim Extension As String
Dim Continue As Boolean
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
Continue = True
Extension = ".DXF"
Row = 2
While Continue
If Len(Range("B" & CStr(Row)).Value) = 0 Then Exit Sub
If Len(Dir(Folder.Path & "\" & Range("B" & CStr(Row)).Value & "*" & Extension)) = 0 Then
Range("F" & CStr(Row)).Value = "No"
Else
Range("F" & CStr(Row)).Value = "Yes"
End If
Row = Row + 1
Wend
Next
End Sub
I would rethink the approach here. Maybe try a macro to manage the row loop and a function to manage the file lookup
First macro to loop through all file names in Column B and outputs if a file is found in Column C
Second macro to search a folder/subfolder path. If the file is found, the loop ends and returns TRUE. If a file is not found, the macro runs it's course and exists with FALSE
Note the function is just demonstrating the logic. You just need to take the logic you have to manage the folder loop and implement in this function
Sub File_Range()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, i As Long
lr = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
For i = 2 To lr
If Not IsEmpty(ws.Range("B" & i)) Then
ws.Range("C" & i) = File_Exists(Range("B" & i))
End If
Next i
End Sub
Public Function File_Exists(Target As Range) As Boolean
'False until file is found
File_Exists = False
For Each SubFolder In Folder.SubFolders
If Len(Dir(Folder.Path & "\" & Target.Value & "*" & Extension)) Then
File_Exists = True
Exit Function
End If
Next SubFolder
End Function
Check Files for Existence
The Basics
Basically (inaccurately), the following writes all file paths of the required (DXF) files found in the supplied folder path to an array, replaces them with file names without file extension and checks the values (file names) in the source column against the array and finally writes the required results (Yes/No) to the destination column.
Adjust the values in the constants section.
Only run checkFiles, the rest is being called by it.
Additional Functionality
To better understand the flow, in the Immediate window CTRL+G, you can monitor what is happening, if you uncomment the Debug.Print sections. Note that Join will fail if error values, but you can always create a loop like it is done for mData which possibly (probably) contains error values.
It will allow different worksheets for source and destination data.
If will allow source and destination data starting in different rows.
The Code
Option Explicit
Sub checkFiles()
Const FolderPath As String = "C:\Users\Anyone\DXF"
Const FileExt As String = "DXF" ' Not case-sensitive i.e. 'DXF = dxf'
Const fFound As String = "Yes"
Const fNotFound As String = "No"
Const srcName As String = "Sheet1"
Const srcFirst As String = "B2"
Const dstName As String = "Sheet1"
Const dstFirst As String = "F2"
Dim wb As Workbook
Set wb = ThisWorkbook
Dim rng As Range ' (Source and Destination) Data Range
Dim Data As Variant ' (Source and Destination) Data Array
Dim fData() As String ' File Data Array
Dim mData As Variant ' Match Data Array
Dim n As Long ' File Data and (Match) Data Array Elements Counter
' Write values from Source Range to Data Array.
Set rng = defineColumnRange(defineRange(wb.Worksheets(srcName), srcFirst))
Data = getColumn(rng)
'Debug.Print "Source Data:" & vbLf & Join(Application.Transpose(Data), vbLf)
' Write file paths to File Data Array.
fData = getFilePaths(FolderPath, "*." & FileExt)
'Debug.Print "File Data - File Paths:" & vbLf & Join(fData, vbLf)
' Replace file paths with file names without file extension.
For n = LBound(fData) To UBound(fData)
fData(n) = FileFromPath(fData(n), True) ' 'True' means no extension.
Next n
'Debug.Print "File Data - File Names:" & vbLf & Join(fData, vbLf)
' Write 'matches' to Match Data Array.
mData = Application.Match(Data, fData, 0)
'Debug.Print "Match Data:"
'For n = 1 To UBound(mData)
' Debug.Print mData(n, 1)
'Next
' Overwrite values in Data Array with 'matching results'.
For n = 1 To UBound(Data) ' or 'UBound(mData)'
If IsNumeric(mData(n, 1)) Then
Data(n, 1) = fFound
Else
Data(n, 1) = fNotFound
End If
Next n
'Debug.Print "Destination Data:" & vbLf _
& Join(Application.Transpose(Data), vbLf)
' Write values from Data Array to Destination Range.
With defineRange(wb.Worksheets(dstName), dstFirst)
Dim RowOffset As Long: RowOffset = .Row - rng.Row
Dim ColumnOffset As Long: ColumnOffset = .Column - rng.Column
Set rng = .Worksheet.Range(rng.Offset(RowOffset, ColumnOffset).Address)
End With
rng.Value = Data
End Sub
Function defineRange( _
ws As Worksheet, _
ByVal RangeAddress As String) _
As Range
On Error Resume Next
Set defineRange = ws.Range(RangeAddress)
On Error GoTo 0
End Function
Function defineColumnRange( _
FirstCell As Range) _
As Range
If Not FirstCell Is Nothing Then
With FirstCell
Dim rng As Range
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1)
Set rng = rng.Find("*", , xlFormulas, , , xlPrevious)
If Not rng Is Nothing Then
Set defineColumnRange = .Resize(rng.Row - .Row + 1)
End If
End With
End If
End Function
Function getColumn( _
rng As Range) _
As Variant
If Not rng Is Nothing Then
If InStr(rng.Address, ":") > 0 Then
getColumn = rng.Value
Else
Dim Data As Variant
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
getColumn = Data
End If
End If
End Function
Function getFilePaths( _
ByVal FolderPath As String, _
Optional ByVal FilePattern As String = "") _
As Variant
Dim ExecString As String
ExecString = "cmd /c Dir """ & FolderPath & Application.PathSeparator _
& FilePattern & """ /b/s"
getFilePaths = Filter(Split(CreateObject("WScript.Shell") _
.Exec(ExecString).StdOut.ReadAll, vbCrLf), ".") ' 'vbCrLf' is a must.
End Function
Function FileFromPath( _
ByVal FilePath As String, _
Optional ByVal NoExtension As Boolean = False) _
As String
Dim FileName As String
FileName = Right(FilePath, _
Len(FilePath) - InStrRev(FilePath, "\"))
If NoExtension Then
FileName = Left(FileName, InStrRev(FileName, ".") - 1)
End If
FileFromPath = FileName
End Function
I need help creating separate text files from each row in an excel spread sheet called "worksheet". I want the text files to be named with content of Column A, with columns B-G being the content, preferably with a double hard return between each column in the text file, so each column will have a blank line in between them.
Is this possible? How would I go about it. thanks!
#nutsch's answer is perfectly fine and should work 99.9% of the time. In the rare occasion that FSO is not available, here's a version that doesn't have a dependency. As is, it does require that the source worksheet doesn't have any blank rows in the content section.
Sub SaveRowsAsCSV()
Dim wb As Excel.Workbook, wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim r As Long, c As Long
Set wsSource = ThisWorkbook.Worksheets("worksheet")
Application.DisplayAlerts = False 'will overwrite existing files without asking
r = 1
Do Until Len(Trim(wsSource.Cells(r, 1).Value)) = 0
ThisWorkbook.Worksheets.Add ThisWorkbook.Worksheets(1)
Set wsTemp = ThisWorkbook.Worksheets(1)
For c = 2 To 7
wsTemp.Cells((c - 1) * 2 - 1, 1).Value = wsSource.Cells(r, c).Value
Next c
wsTemp.Move
Set wbNew = ActiveWorkbook
Set wsTemp = wbNew.Worksheets(1)
'wbNew.SaveAs wsSource.Cells(r, 1).Value & ".csv", xlCSV 'old way
wbNew.SaveAs "textfile" & r & ".csv", xlCSV 'new way
'you can try other file formats listed at http://msdn.microsoft.com/en-us/library/office/aa194915(v=office.10).aspx
wbNew.Close
ThisWorkbook.Activate
r = r + 1
Loop
Application.DisplayAlerts = True
End Sub
The attached VBA macro will do it, saving the txt files in C:\Temp\
Sub WriteTotxt()
Const forReading = 1, forAppending = 3, fsoForWriting = 2
Dim fs, objTextStream, sText As String
Dim lLastRow As Long, lRowLoop As Long, lLastCol As Long, lColLoop As Long
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
For lRowLoop = 1 To lLastRow
Set fs = CreateObject("Scripting.FileSystemObject")
Set objTextStream = fs.opentextfile("c:\temp\" & Cells(lRowLoop, 1) & ".txt", fsoForWriting, True)
sText = ""
For lColLoop = 1 To 7
sText = sText & Cells(lRowLoop, lColLoop) & Chr(10) & Chr(10)
Next lColLoop
objTextStream.writeline (Left(sText, Len(sText) - 1))
objTextStream.Close
Set objTextStream = Nothing
Set fs = Nothing
Next lRowLoop
End Sub
For the benefit of others, I sorted the problem out. I replaced "Chr(10) & Chr(10)" with "Chr(13) & Chr(10)" and it worked perfectly.
I used the simple code below for saving my excel rows as a text file or many other format for quite a long time now and it has always worked for me.
Sub savemyrowsastext()
Dim x
For Each cell In Sheet1.Range("A1:A" & Sheet1.UsedRange.Rows.Count)
' you can change the sheet1 to your own choice
saveText = cell.Text
Open "C:\wamp\www\GeoPC_NG\sogistate\igala_land\" & saveText & ".php" For Output As #1
Print #1, cell.Offset(0, 1).Text
Close #1
For x = 1 To 3 ' Loop 3 times.
Beep ' Sound a tone.
Next x
Next cell
End Sub
Note:
1. Column A1 = file title
2. column B1 = file content
3. Until the last row containing text (ie empty rows)
in reverse order, if you want to make it like this;
1. Column A1 = file title
2. column A2 = file content
3. Until the last row containing text (ie empty rows), just change Print #1, cell.Offset(0, 1).Text to Print #1, cell.Offset(1, 0).Text
My folder location = C:\wamp\www\GeoPC_NG\kogistate\igala_land\
My file extension = .php, you can change the extension to your own choice (.txt, .htm & .csv etc)
I included bip sound at the end of each saving to know if my work is going on
Dim x
For x = 1 To 3 ' Loop 3 times.
Beep ' Sound a tone.