Please help Looping In VBA

**shelim481** · 08-30-2018, 12:44 PM

I Have the below VBA code but i cant get it to loop every time, until "rFound" is noting, also how do i change "Const FlName" so that it would save in the same file directoy as the xlsm file but everytimes it loops i want the txt file it creates to change its name in consecutive order e.g. chunk 1.txt, chunk 2.txt?
all once "rFound" is noting i want it to say complete work

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const MAX_PATH As Long = 260
Function TempPath() As String
    TempPath = String$(MAX_PATH, Chr$(0))
    GetTempPath MAX_PATH, TempPath
    TempPath = Replace(TempPath, Chr$(0), "")
End Function

Sub Findexpand()
    Dim rFound As Range
    Dim FCell As String
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("Test")
    Dim k As Long
    Dim tmpFile As String
    Dim MyData As String, strData() As String
    Dim entireline As String
    Dim filesize As Integer
    Dim Test As Boolean

    On Error Resume Next
    Set rFound = Cells.Find(What:="*", _
                    After:=Cells(Rows.Count, Columns.Count), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
    
   On Error GoTo 0
    
     If rFound Is Nothing Then
        

        MsgBox "Noting found"
       
         Else
    
    
    FCell = rFound.Address(RowAbsolute:=False, ColumnAbsolute:=False, External:=False)
    k = sh.Range(FCell, sh.Range(FCell).End(xlDown).End(xlDown).End(xlUp)).Rows.Count
    ActiveSheet.Range(FCell).Select
    Selection.Resize(numRows + k, numColumns + 50).Select
    Selection.Cut
    ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
    ActiveSheet.Paste
    
    '~~> change this to orginal file location
    Const FlName = "C:\Users\Desktop\Chunk1.txt"

    '~~> Create a Temp File
    tmpFile = TempPath & Format(Now, "ddmmyyyyhhmmss") & ".txt"

    ActiveWorkbook.SaveAs Filename:=tmpFile _
    , FileFormat:=xlText, CreateBackup:=False

    '~~> Read the entire file in 1 Go!
    Open tmpFile For Binary As #1
    MyData = Space$(LOF(1))
    Get #1, , MyData
    Close #1
    strData() = Split(MyData, vbCrLf)

    '~~> Get a free file handle
    filesize = FreeFile()

    '~~> Open your file
    Open FlName For Output As #filesize

    For i = LBound(strData) To UBound(strData)
        entireline = Replace(strData(i), """", "")
        '~~> Export Text
        Print #filesize, entireline
    Next i

    Close #filesize
    Application.DisplayAlerts = False

    'Worksheets(Worksheets.Count).Activate
    'ActiveSheet.Delete
    'Application.DisplayAlerts = True

   
'   Kill tmpFile

    End If
  MsgBox "Done"
     
   
End Sub

**6StringJazzer** · 08-30-2018, 03:59 PM

I am giving this a try but can't test it without your file.

You have a bug that I don't know how to fix because I am not sure what you are doing:

    Selection.Resize(numRows + k, numColumns + 50).Select

numRows and numColumns are not declared and never assigned a values. So they will be 0 here. I strongly recommend to everyone that they declare variables. Doing so prevents a lot of bugs and runtime errors.

Option Explicit

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const MAX_PATH As Long = 260
Function TempPath() As String
    TempPath = String$(MAX_PATH, Chr$(0))
    GetTempPath MAX_PATH, TempPath
    TempPath = Replace(TempPath, Chr$(0), "")
End Function

Sub Findexpand()
    Dim rFound As Range, FirstFound As Range
    Dim FCell As String
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("Test")
    Dim k As Long
    Dim tmpFile As String
    Dim MyData As String, strData() As String
    Dim entireline As String
    Dim filesize As Integer
    Dim Test As Boolean
    Dim numRows As Long, numColumns As Long  '''''' NEED VALUES
    Dim i As Long
    Dim FlName As String
    Dim Sequence As Long

    On Error Resume Next
    Set rFound = Cells.Find(What:="*", _
                    After:=Cells(Rows.Count, Columns.Count), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
    
   On Error GoTo 0
   
   If rFound Is Nothing Then
   
      MsgBox "NotHing found"
   
   Else
      Set FirstFound = rFound
      Do
      
         FCell = rFound.Address(RowAbsolute:=False, ColumnAbsolute:=False, External:=False)
         k = sh.Range(FCell, sh.Range(FCell).End(xlDown).End(xlDown).End(xlUp)).Rows.Count
         ActiveSheet.Range(FCell).Select
         Selection.Resize(numRows + k, numColumns + 50).Select
         Selection.Cut
         ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
         ActiveSheet.Paste
         
         '~~> change this to orginal file location
         Sequence = Sequence + 1
         FlName = "C:\Users\Desktop\Chunk" & Sequence & ".txt"
         
         '~~> Create a Temp File
         tmpFile = TempPath & Format(Now, "ddmmyyyyhhmmss") & ".txt"
         
         ActiveWorkbook.SaveAs Filename:=tmpFile _
         , FileFormat:=xlText, CreateBackup:=False
         
         '~~> Read the entire file in 1 Go!
         Open tmpFile For Binary As #1
         MyData = Space$(LOF(1))
         Get #1, , MyData
         Close #1
         strData() = Split(MyData, vbCrLf)
         
         '~~> Get a free file handle
         filesize = FreeFile()
         
         '~~> Open your file
         Open FlName For Output As #filesize
         
         For i = LBound(strData) To UBound(strData)
         entireline = Replace(strData(i), """", "")
         '~~> Export Text
         Print #filesize, entireline
         Next i
         
         Close #filesize
         Application.DisplayAlerts = False
         
         'Worksheets(Worksheets.Count).Activate
         'ActiveSheet.Delete
         'Application.DisplayAlerts = True
         
         
         '   Kill tmpFile
         
         Set rFound = Cells.FindNext(After:=rFound)
      
      
      Loop Until rFound Is Nothing Or rFound.Address = FirstFound
      
   End If
   
   MsgBox "Done"
     
   
End Sub

**shelim481** · 08-30-2018, 04:18 PM

Hi, thank you for your help much appreciated, i have large amount of data but it always starts at cell E5, i want to cut the data and put it into a new sheet then exports as TXT file, finally i want to repeat this until no data is left in the original work sheet. now im getting a error at

 Open FlName For Output As #filesize

run time error 76

**6StringJazzer** · 08-30-2018, 04:30 PM

What is the value of FCell when this error occurs?

**shelim481** · 08-30-2018, 04:51 PM

Now i get runtime error 91, for some reason it it starts separating each line into different sheets, it just does the first sheet correctly. but no txt files produced.

**shelim481** · 08-30-2018, 04:58 PM

Attachment 588544

all i wanted was to separate out the data into txt files of 50 columns (with no speech marks)...the data is more complicated then one attached...
I got it working with a little modification but i cant seem to get the txt files.....Any ideas?

Option Explicit

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const MAX_PATH As Long = 260
Function TempPath() As String
    TempPath = String$(MAX_PATH, Chr$(0))
    GetTempPath MAX_PATH, TempPath
    TempPath = Replace(TempPath, Chr$(0), "")
End Function

Sub Findexpand()
    Dim rFound As Range, FirstFound As Range
    Dim FCell As String
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("Sheet1")
    Dim k As Long
    Dim tmpFile As String
    Dim MyData As String, strData() As String
    Dim entireline As String
    Dim filesize As Integer
    Dim Test As Boolean
    Dim numRows As Long, numColumns As Long  '''''' NEED VALUES
    Dim i As Long
    Dim FlName As String
    Dim Sequence As Long

    On Error Resume Next
    Set rFound = Cells.Find(What:="*", _
                    After:=Cells(Rows.Count, Columns.Count), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
    
   On Error GoTo 0
   
   If rFound Is Nothing Then
   
      MsgBox "NotHing found"
   
   Else
      Set FirstFound = rFound
      Do
         ThisWorkbook.Sheets("Sheet1").Activate
         FCell = rFound.Address(RowAbsolute:=False, ColumnAbsolute:=False, External:=False)
         k = sh.Range(FCell, sh.Range(FCell).End(xlDown).End(xlDown).End(xlUp)).Rows.Count
         ActiveSheet.Range(FCell).Select
         Selection.Resize(numRows + k, numColumns + 50).Select
         Selection.Cut
         ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
         ActiveSheet.Paste
         
         '~~> change this to orginal file location
         Sequence = Sequence + 1
         FlName = "C:\Users\Max\Desktop" & Sequence & ".txt"
         
         '~~> Create a Temp File
         tmpFile = TempPath & Format(Now, "ddmmyyyyhhmmss") & ".txt"
         
         ActiveWorkbook.SaveAs Filename:=tmpFile _
         , FileFormat:=xlText, CreateBackup:=False
         
         '~~> Read the entire file in 1 Go!
         Open tmpFile For Binary As #1
         MyData = Space$(LOF(1))
         Get #1, , MyData
         Close #1
         strData() = Split(MyData, vbCrLf)
         
         '~~> Get a free file handle
         filesize = FreeFile()
         
         '~~> Open your file
         Open FlName For Output As #filesize
         
         For i = LBound(strData) To UBound(strData)
         entireline = Replace(strData(i), """", "")
         '~~> Export Text
         Print #filesize, entireline
         Next i
         
         Close #filesize
         Application.DisplayAlerts = False
         
         'Worksheets(Worksheets.Count).Activate
         'ActiveSheet.Delete
         'Application.DisplayAlerts = True
         
         
         '   Kill tmpFile
         ThisWorkbook.Sheets("Sheet1").Activate
         Set rFound = Cells.FindNext(After:=rFound)
      
      
      Loop Until rFound Is Nothing 'Or rFound.Address = FirstFound
      
   End If
   
   MsgBox "Done"
     
   
End Sub

I need the txt files in the same directory as the excel file, but it only works for one text file if i use

FlName = "C:\Users\Max\Desktop\chunk1.txt"

when i use

FlName = "C:\Users\Max\Desktop\chunk" & Sequence & ".txt"

no txt files are created...

**shelim481** · 08-30-2018, 05:48 PM

Working after some thinking ....thank you very much .... just need

FlName = "C:\Users\Max\Desktop\chunk" & Sequence & ".txt"

to be saved at the xlms directory any ideas?
when i change to ThisWorkbook.Path or something similar it does not do anything in the xlms file directory but adds files in the temp directory....

**6StringJazzer** · 08-30-2018, 07:56 PM

I can't help you any further without having your file. Remove any private data and attach it.

The paper clip icon does not work for attachments. Instead, under the text box where you type your reply click the Go Advanced button. On the next screen scroll down and click on Manage Attachments, which will show a pop-up window to Select and Upload a file. Then close the window.