Excel 循环实现方法

blue_li

Excel 循环

请教：想现按照"循环开始“列的上下两行的单元格的值进行比较，如果相同，则继续循环输出该循环内的值。循环可以如上表显示的可以嵌套多层。

excel海

循环 for....next啊

orr89

循环啥，数据呢

blue_li

excel海 发表于 2020-1-14 20:47
循环 for....next啊

关键是循环嵌套层次不定

excel海

你得上表才行,不是谁知道你说的什么呢

blue_li

orr89 发表于 2020-1-14 20:58
循环啥，数据呢

我是想实现无限的循环嵌套，我的代码只实现了一层的循环。

1. Option Explicit
   
2. 
   
3. 
   
4. 
   
5. '进度条函数
   
6. Function GetProgress(curValue, maxValue)
   
7. Dim i As Single, j As Integer, s As String, m As Single, n As Single
   
8. 
   
9. i = maxValue / 20
   
10. j = curValue / i
    
11. 
    
12. For m = 1 To j
    
13.     s = s & "■"
    
14. Next m
    
15. For n = 1 To 20 - j
    
16.     s = s & "□"
    
17. Next n
    
18. GetProgress = s & FormatNumber(curValue / maxValue * 100, 2) & "%"
    
19. End Function
    
20. 
    
21. '创建txt文件
    
22. Sub CreateCim()
    
23.    
    
24.     Dim c_row, c_column, maxrow, Maxcolumn, c_start, c_end, c_lnnbr, option_column, option_colend As Long
    
25.     Dim strCell() As String
    
26.     Dim option_arr() As String
    
27.     Dim strString, sLineEnd As String
    
28.     Dim CreateText As Object
    
29.     Dim SelectSheet As Object
    
30.     Dim WorkbookName As String
    
31.     Dim WorkSheetName As String
    
32.     Dim CurrValue As String
    
33.     Dim DataArr() '用于存放单元格数值，提升效率
    
34.    
    
35.    
    
36.     Set SelectSheet = ActiveWorkbook.ActiveSheet
    
37.     WorkbookName = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1)
    
38.     WorkSheetName = ActiveSheet.Name
    
39.     Set CreateText = CreateObject("ADODB.Stream")
    
40.             
    
41.   On Error GoTo ErrorMessage
    
42. 
    
43.     c_row = 1
    
44.     Maxcolumn = 0
    
45.     Do While SelectSheet.Cells(6, c_row) <> ""
    
46.         Maxcolumn = Maxcolumn + 1
    
47.         c_row = c_row + 1
    
48.     Loop
    
49.    
    
50.     ReDim strCell(Maxcolumn) As String
    
51.    
    
52.     If LCase(Panel.LineFeed.Text) = "chui" Then
    
53.         sLineEnd = vbLf
    
54.     ElseIf LCase(Panel.LineFeed.Text) = "gui" Then
    
55.         sLineEnd = vbCrLf
    
56.     End If
    
57.               
    
58.    
    
59.     c_start = 0
    
60.     c_lnnbr = 0
    
61.     c_end = Maxcolumn + 1
    
62.    
    
63.     For c_column = 1 To Maxcolumn
    
64.         If SelectSheet.Cells(7, c_column) = "loop_start" Then
    
65.            c_start = c_column
    
66.            c_lnnbr = SelectSheet.Cells(8, c_column)
    
67.         End If
    
68.         If SelectSheet.Cells(7, c_column) = "loop_end" Then
    
69.            c_end = c_column
    
70.         End If
    
71.    
    
72.     Next c_column
    
73.    
    
74.     c_row = CLng(Panel.StartLine.Text)
    
75.     maxrow = CLng(Panel.EndLine.Text)
    
76.    
    
77.    
    
78.     '将单元格数据赋于DataArr二维数组
    
79.     ReDim DataArr(1 To maxrow + 1, 1 To Maxcolumn + 1)
    
80.     DataArr = SelectSheet.Cells(1, 1).Resize(maxrow + 1, Maxcolumn + 1).Value
    
81.    
    
82.    
    
83.     With CreateText
    
84.                 .Type = 2
    
85.                 .Charset = Panel.CodePage.Text
    
86.                 .Open
    
87.                
    
88.         For c_row = c_row To maxrow
    
89.                
    
90.                If c_lnnbr = 0 Then
    
91.                strString = "@@batchload " & Panel.QadProgram.Text & sLineEnd
    
92.             ElseIf LCase(DataArr(c_row, c_lnnbr)) <> LCase(DataArr(c_row - 1, c_lnnbr)) Then
    
93.                strString = "@@batchload " & Panel.QadProgram.Text & sLineEnd
    
94.             End If
    
95.             
    
96.             For c_column = 1 To Maxcolumn
    
97.                
    
98.                 '根据内容判断是否输出“内容判断开始”与“内容判断结束”之间的数据
    
99. option_start:
    
100.                 If LCase(DataArr(7, c_column)) = "option_start" Then
     
101.                     
     
102.                     option_column = c_column
     
103.                     If DataArr(8, c_column) <> "" Then
     
104.                         option_column = DataArr(8, c_column)
     
105.                     End If
     
106.                     option_arr = Split(LCase(DataArr(10, c_column)), ",")
     
107.                     
     
108.                     
     
109.                     '如果在第10行没有找到该值，则执行跳过。
     
110.                     If UBound(VBA.Filter(option_arr, LCase(DataArr(c_row, option_column)))) < 0 Or LCase(DataArr(c_row, option_column)) = "" Then
     
111.                                       
     
112.                         For option_colend = c_column To Maxcolumn
     
113.                                 If LCase(DataArr(7, option_colend)) = "option_end" Then
     
114.                                      c_column = option_colend
     
115.                                      Exit For
     
116.                                 End If
     
117.                         Next option_colend
     
118.             
     
119.                     End If
     
120.                 End If
     
121.                
     
122.                  If LCase(DataArr(7, c_column)) = "option_end" Or LCase(DataArr(7, c_column)) = "option_start" Then
     
123.                     If LCase(DataArr(7, c_column + 1)) = "option_start" Then
     
124.                         c_column = c_column + 1
     
125.                         GoTo option_start
     
126.                     End If
     
127.                     c_column = c_column + 1
     
128.                 End If
     
129.                           
     
130.                           
     
131.                 '判断是否输出".","-"或单元格内容
     
132.                 If Trim(Replace(Replace(DataArr(10, c_column), Chr(10), ""), Chr(13), "")) = "." Then
     
133.                     CurrValue = "."
     
134.                 ElseIf Trim(Replace(Replace(DataArr(c_row, c_column), Chr(10), ""), Chr(13), "")) = "" Or Trim(Replace(Replace(DataArr(c_row, c_column), Chr(10), ""), Chr(13), "")) = "-" Then
     
135.                     CurrValue = "-"
     
136.                 Else:
     
137.                     CurrValue = Replace(Replace(DataArr(c_row, c_column), Chr(10), ""), Chr(13), "")
     
138.                 End If
     
139.                
     
140.                 '清除首尾空格
     
141.                 If Panel.trimoption.Value = True And CurrValue <> "." And CurrValue <> "-" And CurrValue <> """""" Then
     
142.                     CurrValue = Trim(CurrValue)
     
143.                 End If
     
144.                
     
145.                 '替换"字符为指定字符
     
146.                 If Panel.Suboption.Value = True And CurrValue <> "." And CurrValue <> "-" And CurrValue <> """""" Then
     
147.                     CurrValue = Replace(CurrValue, Chr(34), Panel.subtext.Value)
     
148.                 End If
     
149.                
     
150.                  '字符前后添加双引号
     
151.                 If DataArr(10, c_column) = "chr" And CurrValue <> "." And CurrValue <> "-" And CurrValue <> """""" Then
     
152.                     CurrValue = Chr(34) & CurrValue & Chr(34)
     
153.                 End If
     
154.                
     
155.                 '转为日期为指定格式
     
156.                 If DataArr(10, c_column) = "dat" And CurrValue <> "." And CurrValue <> "-" And CurrValue <> """""" And CurrValue <> "?" Then
     
157.                     CurrValue = convDate2String(CDate(CurrValue))
     
158.                 End If
     
159. 
     
160.                 '空值指定为""显示
     
161.                 If CurrValue = "-" And Panel.Reoption1.Value = True And DataArr(10, c_column) = "chr" Then
     
162.                     CurrValue = Chr(34) & Chr(34)
     
163.                 End If
     
164. 
     
165.                
     
166.                 strCell(c_column) = CurrValue
     
167.                
     
168.                 '如果该列存在"enterline"则输出一个回车键
     
169.                 If DataArr(11, c_column) = "enterline" Then
     
170.                     strCell(c_column) = strCell(c_column) & sLineEnd
     
171.                 Else
     
172.                     strCell(c_column) = strCell(c_column) & Chr(9)
     
173.                 End If
     
174.                
     
175.                 If c_lnnbr = 0 Then
     
176.                 ElseIf c_column < c_start And LCase(DataArr(c_row, c_lnnbr)) <> LCase(DataArr(c_row - 1, c_lnnbr)) Then
     
177.                    strString = strString & strCell(c_column)
     
178.                 End If
     
179.                
     
180.                 If c_column > c_start And c_column < c_end Then
     
181.                    strString = strString & strCell(c_column)
     
182.                 End If
     
183.                 If c_lnnbr = 0 Then
     
184.                 ElseIf c_column > c_end And LCase(DataArr(c_row, c_lnnbr)) <> LCase(DataArr(c_row + 1, c_lnnbr)) Then
     
185.                    strString = strString & strCell(c_column)
     
186.                 ElseIf c_column > c_end And c_row >= maxrow And LCase(DataArr(c_row, c_lnnbr)) = LCase(DataArr(c_row + 1, c_lnnbr)) Then
     
187.                   strString = strString & strCell(c_column)
     
188.                 End If
     
189.             Next c_column
     
190.             
     
191.             If c_lnnbr = 0 Then
     
192.                strString = strString & "@@end" & sLineEnd
     
193.                     .WriteText strString
     
194.             ElseIf (LCase(DataArr(c_row, c_lnnbr)) <> LCase(DataArr(c_row + 1, c_lnnbr)) Or c_row >= maxrow) Then
     
195.                strString = strString & "@@end" & sLineEnd
     
196.                     .WriteText strString
     
197.             End If
     
198.             
     
199.             'Application.StatusBar显示进度，但严重影响性能，弃用
     
200.              'Application.StatusBar = c_row - Panel.StartLine.Text & " of the processing record! "
     
201.             
     
202.              'Panel.Messagetext.Caption = "Please wait!   [  " & c_row - Panel.StartLine.Text & "  ] of the processing record!" & vbCrLf & "Selected [ " & WorkbookName & " ][ " & WorkSheetName & " ]"
     
203.              Panel.progress.Caption = GetProgress(c_row - Panel.StartLine.Text + 1, maxrow - Panel.StartLine.Text + 1)
     
204.             'Application.StatusBar = GetProgress(c_row - Panel.StartLine.Text + 1, maxrow - Panel.StartLine.Text + 1)
     
205.             '响应取消，返回界面窗体
     
206.              If Panel.CreateFile.Enabled = True Then
     
207.                 Panel.Messagetext.Caption = "Running process has been cancelled."
     
208.              Exit Sub
     
209.              End If
     
210.             
     
211.              DoEvents
     
212.             
     
213.         Next c_row
     
214.         
     
215.         .SaveToFile Panel.Pathtext.Text & Panel.Nametext.Text, 2
     
216. 
     
217.    
     
218.     End With
     
219.         
     
220.     Set CreateText = Nothing
     
221.     Set SelectSheet = Nothing
     
222.     Panel.Messagetext.ForeColor = &H0&
     
223.     Panel.Messagetext.Caption = "Created successfully! Save in " + Panel.Pathtext.Text & Panel.Nametext.Text & " ."
     
224.     Exit Sub
     
225. ErrorMessage:
     
226.     Panel.Messagetext.ForeColor = &HFF&
     
227.     Panel.Messagetext.Caption = "Created failed!Please check the data in Column " & c_column & " Row " & c_row & " ."
     
228.     SelectSheet.Cells(c_row, c_column).Select
     
229.     Set CreateText = Nothing
     
230.     Set SelectSheet = Nothing
     
231.     Call LoadPane.InterfaceEnabledToTrue
     
232.       
     
233. End Sub
     
234. 
     

复制代码