Looping Macro в Excel

Question

Я хотел бы прокрутить лист Excel и сохранить значения на основе уникального идентификатора в текстовом файле.

У меня возникли проблемы с циклом, и я провел исследование на нем без везения, и мой текущий вложенный цикл постоянно переполняется. Вместо обновления соответствующей ячейки при изменении управляющей переменной она продолжает сохранять начальное значение индекса для всех итераций 32767.

Может кто-нибудь объяснить, почему это происходит, и обеспечить способ его исправления ?.

Sub SortLetr_Code() 
'sort columns for Letr_Code files 

    Dim lr As Long 

    Application.ScreenUpdating = False 
    lr = Cells(Rows.Count, 1).End(xlUp).Row 

    Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1 

    Application.ScreenUpdating = True 

    'Value of cell for example B1 starts out as X 
    Dim x As Integer 
    Dim y As Integer 

    x = 2 
    y = 2 

'Cell References 

    Dim rwCounter As Range 
    Dim rwCorresponding As Range 
    Dim rwIndexValue As Range 
    Dim rwIndexEnd As Range 
    Dim rwIndexStore As Range 

    'Variables for files that will be created 
    Dim FilePath As String 
    Dim Filename As String 
    Dim Filetype As String 

    'Variables defined 
    FilePath = "C:\Users\Home\Desktop\SURLOAD\" 
    Filetype = ".dat" 

    'Use Cell method for Loop 
    rwIndex = Cells(x, "B").Value 
    Set rwCounter = Range("B" & x) 

    'Use Range method for string manipulation 
    Set rwCorresponding = Range("A" & x) 
    Set rwIndexValue = Range("B" & y) 
    Set rwIndexStore = Range("B" & x) 
    Set rwIndexEnd = Range("B:B").End(xlUp) 

    'Objects for creating the text files 
    Dim FileCreate As Object 
    Set FileCreate = CreateObject("Scripting.FileSystemObject") 

    'Object for updating the file during the loop 
    Dim FileWrite As Object 

    For Each rwIndexStore In rwIndexEnd.Cells 
     'Get Substring of cell value in BX for the file name 
     Do Until IsEmpty(rwCounter) 

      Filename = Mid$(rwIndexValue, 7, 5) 
      Set FileWrite = FileCreate.CreateTextFile(FilePath + Filename + Filetype) 

      'Create the file 
      FileWrite.Write (rwCorresponding & vbCrLf) 

      Do 
       'Add values to the textfile 
       x = x + 1 
       FileWrite.Write (rwCorresponding & vbCrLf) 

      Loop While rwCounter.Value Like rwIndexValue.Value 

      'Close this file 
      FileWrite.Close 

      y = x 
     Loop 
    Next rwIndexStore 

End Sub 

Answer 1

Это решение.

Sub GURMAIL_File() 
'sort columns for Letr_Code files 
    Dim lr As Long 

    Application.ScreenUpdating = False 
    lr = Cells(Rows.Count, 1).End(xlUp).Row 

    Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1 

    Application.ScreenUpdating = True 

    'Variables that store cell number 
    Dim Corresponding As Integer 
    Dim Index As Integer 
    Dim Counter As Integer 

    Corresponding = 2 
    Index = 2 
    Counter = 2 

    'Cell References 
    Dim rwIndexValue As Range 

    'Variables for files that will be created 
    Dim l_objFso As Object 
    Dim FilePath As String 

    Dim Total As String 
    Dim Filename As String 
    Dim Filetype As String 
    Dim FolderName As String 

    'Variables defined 
    FilePath = "C:\Users\Home\Desktop\SURLOAD\" 
    'Name of the folder to be created 
    FolderName = Mid$(ActiveWorkbook.Name, 9, 8) & "\" 
    'Folder path 
    Total = FilePath & FolderName 
    'File Extension 
    Filetype = ".dat" 

    'Object that creates the folder 
    Set l_objFso = CreateObject("Scripting.FileSystemObject") 

    'Objects for creating the text files 
    Dim FileCreate As Object 
    Set FileCreate = CreateObject("Scripting.FileSystemObject") 

    'Object for updating the file during the loop 
    Dim FileWrite As Object 

    'Get Substring of letter code in order to name the file. End this loop once ID field is null. 
    Do While Len(Range("A" & Corresponding)) > 0 
     'Create the directory if it does not exist 
     If Not l_objFso.FolderExists(Total) Then 
      l_objFso.CreateFolder (Total) 
     End If 

     'Refence to cell containing a letter code 
     Set rwIndexValue = Range("B" & Index) 
     'Substring of that letter code 
     Filename = Mid$(rwIndexValue, 7, 5) 
     'Create the file using the substring and store it in the proper location 
     Set FileWrite = FileCreate.CreateTextFile(Total + Filename + Filetype, True) 

     'For each letter code, find the corresponding values. End the loop once the last value for the letter code is stored. 
     Do While Range("B" & Index) Like Range("B" & Counter) 
      'Add each line to the text file. 
      FileWrite.WriteLine (Range("A" & Corresponding)) 

      'Incrementer variables that allow you to exit the loop 
      'if you have reached the last value of the current letter code. 
      Corresponding = Corresponding + 1 
      Counter = Counter + 1 
     Loop 

     'Close the file you were writing to 
     FileWrite.Close 

     'Make sure that Index value is updated to the next letter code 
     Index = Counter 
     'In case Index value needs updating (safeguard to make sure that the new letter code is stored to index value). 
     Set rwIndexValue = Range("B" & Index) 

    Loop 
End Sub 

Answer 2

Я не вижу места, которое вы устанавливаете rwCounter внутри цикла.

Похоже, что он будет оставаться на расстоянии («B2»), и x будет продолжать увеличиваться до тех пор, пока он не достигнет ошибки, либо на пределе целого числа, либо надолго.

Set rwCounter = Range("B" & x) добавить где-то внутри цикла, чтобы увеличить его