Excel 在第一个 Sub 后冻结。

huangapple
go评论47阅读模式
英文:

Excel freezes after first Sub

问题

这是您的代码的翻译部分：

我有以下代码，应该为每个用户在另一个工作表中创建一份副本。由于每个用户的输入数据不同，我必须使用用户名的出现来定义范围。不幸的是，最后一个不起作用（其中“Total”代表包含数据的最后一行），如果注释掉最后一个，尽管它们各自可以工作，但在第一个子过程SelectRange()之后，Excel会冻结。有人能帮忙吗？

这是代码：

Sub Main()
    Call SelectRangeUser1
    Call SelectRangeUser2
    Call SelectRangeUser3
    Call SelectRangeUser4
    Call SelectRangeUser5
    Call SelectRangeUser6
    Call SelectRangeUser7
    Call SelectRangeUser8
End Sub

Sub SelectRangeUser1()
    Worksheets("Data").Activate
    Dim startCell As Range
    Dim endCell As Range
    Dim searchStringStart As String
    Dim searchStringEnd As String
    Dim searchStringStop As String
    Dim currentCell As Range

    searchStringStart = "User1" 
    searchStringEnd = "User2" 
    searchStringStop = "User2" 

    ' 在活动工作表中搜索起始字符串
    For Each currentCell In ActiveSheet.UsedRange.Cells
        If currentCell.Value = searchStringStart Then
            Set startCell = currentCell
            Exit For
        End If
    Next currentCell

    ' 如果找到起始字符串，搜索结束或停止字符串
    For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
        If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
            Set endCell = currentCell.Offset(-2) ' 向上偏移两行的结束单元格
            Exit For
        End If
    Next currentCell

    ' 如果找到结束或停止字符串，选择从起始到结束的范围
    If Not endCell Is Nothing Then
        Dim newSheet As Worksheet
        Set newSheet = Worksheets.Add
        newSheet.Name = "User1"
        Dim newRange As Range
        Set newRange = Range(startCell, endCell).Resize(, 11)
        newRange.Copy newSheet.Range("A1")
        newRange.Name = "User1"
    End If
End Sub

' 以下是SelectRangeUser2到SelectRangeUser7的类似翻译，只需更改用户号码：

...

Sub SelectRangeUser8()
    Worksheets("Data").Activate
    Dim startCell As Range
    Dim endCell As Range
    Dim searchStringStart As String
    Dim searchStringEnd As String
    Dim searchStringStop As String
    Dim currentCell As Range
    Dim lastStartCell As Range ' 存储找到起始字符串的最后一个单元格的变量

    searchStringStart = "User8" 
    searchStringEnd = "Total"
    searchStringStop = "Total"

    ' 在活动工作表中搜索起始字符串
    For Each currentCell In ActiveSheet.UsedRange.Cells
        If currentCell.Value = searchStringStart Then
            Set lastStartCell = currentCell ' 更新找到起始字符串的最后一个单元格
            If startCell Is Nothing Then
                Set startCell = currentCell
            End If
        End If
    Next currentCell

    ' 如果找到起始字符串，搜索最后一个起始字符串后的结束或停止字符串
    If Not lastStartCell Is Nothing Then
        For Each currentCell In ActiveSheet.Range(lastStartCell.Offset(1), ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
            If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
                Set endCell = currentCell.Offset(-2) ' 向上偏移两行的结束单元格
            End If
        Next currentCell
    End If

    ' 如果找到结束或停止字符串，选择从起始到结束的范围
    If Not endCell Is Nothing Then
        Dim newSheet As Worksheet
        Set newSheet = Worksheets.Add ' 创建一个新工作表
        newSheet.Name = "User8" ' 为新工作表分配名称
        Dim newRange As Range
        Set newRange = Range(startCell, endCell).Resize(, 11) ' 调整所选范围的大小，包括A到K列
        newRange.Copy newSheet.Range("A1") ' 复制所选范围到新工作表
        newRange.Name = "User8" ' 为所选范围分配名称
    End If
End Sub

正如已经解释的，我尝试设置一个例程来识别输入的变化范围并将其复制到同一工作簿中的新工作表中。

英文:

I have the following Code that should give me for every User a copy to another Worksheet. As the input data for every varies, I have to define the ranges with the appearances of Usernames. Unfortunately, the last one does not work (Where "Total" stands for the last row containing data)and if comment the last one out, Excel freezes after the first Sub SelectRange() although they work individually. Can someone help here?

Here is the Code:

Sub Main()
Call SelectRangeUser1
Call SelectRangeUser2
Call SelectRangeUser3
Call SelectRangeUser4
Call SelectRangeUser5
Call SelectRangeUser6
Call SelectRangeUser7
Call SelectRangeUser8
End Sub
Sub SelectRangeUser1()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
searchStringStart = "User1" 
searchStringEnd = "User2" 
searchStringStop = "User2" 
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set startCell = currentCell
Exit For
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add
newSheet.Name = "User1"
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11)
newRange.Copy newSheet.Range("A1")
newRange.Name = "User1"
End If
End Sub
Sub SelectRangeUser2()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
searchStringStart = "User2" 
searchStringEnd = "User3" 
searchStringStop = "User3" 
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set startCell = currentCell
Exit For
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add
newSheet.Name = "User2"
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11)
newRange.Copy newSheet.Range("A1")
newRange.Name = "User2"
End If
End Sub
Sub SelectRangeUser3()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
searchStringStart = "User3" 
searchStringEnd = "User4"
searchStringStop = "User4"
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set startCell = currentCell
Exit For
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add
newSheet.Name = "User3"
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11)
newRange.Copy newSheet.Range("A1")
newRange.Name = "User3"
End If
End Sub
Sub SelectRangeUser4()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
searchStringStart = "User4" 
searchStringEnd = "User5" 
searchStringStop = "User5" 
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set startCell = currentCell
Exit For
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add
newSheet.Name = "User4"
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11)
newRange.Copy newSheet.Range("A1")
newRange.Name = "User4"
End If
End Sub
Sub SelectRangeUser5()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
searchStringStart = "User5"
searchStringEnd = "User6" 
searchStringStop = "User6" 
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set startCell = currentCell
Exit For
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add
newSheet.Name = "User5"
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11)
newRange.Copy newSheet.Range("A1")
newRange.Name = "User5"
End If
End Sub
Sub SelectRangeUser6()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
searchStringStart = "User6" 
searchStringEnd = "User7" 
searchStringStop = "User7" 
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set startCell = currentCell
Exit For
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add
newSheet.Name = "User6"
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11)
newRange.Copy newSheet.Range("A1")
newRange.Name = "User6"
End If
End Sub
Sub SelectRangeUser7()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
Dim startStringCount As Integer ' counter for the number of times the start string is found
searchStringStart = "User7" ' change this to your specific start string
searchStringEnd = "User8" ' change this to your specific end string
searchStringStop = "User8" ' change this to your specific stop string
startStringCount = 0 ' initialize start string count to zero
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
startStringCount = startStringCount + 1 ' increment start string count
If startStringCount = 2 Then ' if this is the second appearance of the start string
Set startCell = currentCell
Exit For
End If
End If
Next currentCell
' if start string is found, search for the end or stop string
For Each currentCell In ActiveSheet.Range(startCell, ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
Exit For
End If
Next currentCell
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add ' create a new worksheet
newSheet.Name = "User7" ' assign a name to the new worksheet
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11) ' resize the selected range to include columns A to K
newRange.Copy newSheet.Range("A1") ' copy the selected range to the new worksheet
newRange.Name = "User7" ' assign a name to the selected range
End If
End Sub
Sub SelectRangeUser8()
Worksheets("Data").Activate
Dim startCell As Range
Dim endCell As Range
Dim searchStringStart As String
Dim searchStringEnd As String
Dim searchStringStop As String
Dim currentCell As Range
Dim lastStartCell As Range ' variable to store the last cell where the start string was found
searchStringStart = "User8" 
searchStringEnd = "Total"
searchStringStop = "Total"
' search for the start string in the active sheet
For Each currentCell In ActiveSheet.UsedRange.Cells
If currentCell.Value = searchStringStart Then
Set lastStartCell = currentCell ' update the last cell where the start string was found
If startCell Is Nothing Then
Set startCell = currentCell
End If
End If
Next currentCell
' if start string is found, search for the end or stop string after the last cell where the start string was found
If Not lastStartCell Is Nothing Then
For Each currentCell In ActiveSheet.Range(lastStartCell.Offset(1), ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
If currentCell.Value = searchStringEnd Or currentCell.Value = searchStringStop Then
Set endCell = currentCell.Offset(-2) ' offset end cell by two rows
End If
Next currentCell
End If
' if end or stop string is found, select the range from start to end
If Not endCell Is Nothing Then
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add ' create a new worksheet
newSheet.Name = "User8" ' assign a name to the new worksheet
Dim newRange As Range
Set newRange = Range(startCell, endCell).Resize(, 11) ' resize the selected range to include columns A to K
newRange.Copy newSheet.Range("A1") ' copy the selected range to the new worksheet
newRange.Name = "User8" ' assign a name to the selected range
End If
End Sub

As already explained, I tried to set up a routine to identify changing ranges from an input and copying it to a new Worksheet in the same Workbook.

答案1

得分: 0

我不确定是否要发布这篇文章，因为它并不能解释为什么您的代码会冻结 - 它确实展示了一种更好和更短的搜索所有用户的方法，前提是编号中没有间隙。如果存在间隙，您可能需要更改用户名查找的方式 - 可能是在数据中列出名称的唯一列表，然后搜索（如果有365个）。这不会检查是否存在具有相同名称的工作表，因此可能需要为此放入错误处理程序。

Sub Extract()
Dim SearchString As String
SearchString = "User"
Dim UserNum As Long
UserNum = 1
'此块中以.开头的任何范围都是指向包含此代码的工作簿中Sheet1的第一列。
With ThisWorkbook.Worksheets("Sheet1").Columns(1)
Dim foundStart As Range
Dim foundEnd As Range
Do
'查找用户名的第一个和最后一个出现（xlNext，xlPrevious）。
'注意 - 用户名称从第2行开始，第1行是标题。
'搜索从第一个单元格之后开始（.Cells(1,1) ）。
Set foundStart = .Find(SearchString & UserNum, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext)
Set foundEnd = .Find(SearchString & UserNum, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious)
'如果找到范围，然后创建新工作表并将数据复制到其中。
If Not foundStart Is Nothing Then
Dim wrkSht As Worksheet
Set wrkSht = ThisWorkbook.Worksheets.Add
wrkSht.Name = SearchString & UserNum
.Range(foundStart, foundEnd).Resize(, 11).Copy _
Destination:=wrkSht.Cells(1, 1)
End If
'增加用户名1并再次搜索。
UserNum = UserNum + 1
Loop While Not foundStart Is Nothing
End With
End Sub

对于特定的用户名，您可以使用以下代码。不过，最好将用户名作为参数传递。

Sub Extract()
Dim UsrNames As Variant
UsrNames = Array("Me", "You", "Someone else")
With ThisWorkbook.Worksheets("Sheet1").Columns(1)
Dim UsrName As Variant
For Each UsrName In UsrNames
Dim foundStart As Range
Dim foundEnd As Range
'查找用户名的第一个和最后一个出现（xlNext，xlPrevious）。
'注意 - 用户名称从第2行开始，第1行是标题。
'搜索从第一个单元格之后开始（.Cells(1,1) ）。
Set foundStart = .Find(UsrName, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext)
Set foundEnd = .Find(UsrName, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious)
'如果找到范围，然后创建新工作表并将数据复制到其中。
If Not foundStart Is Nothing Then
Dim wrkSht As Worksheet
Set wrkSht = ThisWorkbook.Worksheets.Add
wrkSht.Name = UsrName
.Range(foundStart, foundEnd).Resize(, 11).Copy _
Destination:=wrkSht.Cells(1, 1)
End If
Next UsrName
End With
End Sub
英文:

I wasn't sure whether to post this as it doesn't answer why your code is freezing - it does show a better and shorter way to search for all users providing there's no gaps in the numbering.
If there are gaps you'd have to change the username look up - maybe a unique list of names in your data and search through that (UNIQUE formula if you've got 365).

This doesn't check for existing worksheets with the same name, so maybe put an error handler in for that.

Sub Extract()
Dim SearchString As String
SearchString = "User"
Dim UserNum As Long
UserNum = 1
'Any range in this block that starts with . is refering to column A
'in Sheet1 of the workbook containing this code.
With ThisWorkbook.Worksheets("Sheet1").Columns(1)
Dim foundStart As Range
Dim foundEnd As Range
Do
'Find the first and last occurrence of the user name (xlNext, xlPrevious).
'Note - user names start on row 2, with heading on row 1.
'The search starts AFTER the first cell ( .Cells(1,1) )
Set foundStart = .Find(SearchString & UserNum, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext)
Set foundEnd = .Find(SearchString & UserNum, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious)
'If the range is found then create a new sheet and copy the data to it.
If Not foundStart Is Nothing Then
Dim wrkSht As Worksheet
Set wrkSht = ThisWorkbook.Worksheets.Add
wrkSht.Name = SearchString & UserNum
.Range(foundStart, foundEnd).Resize(, 11).Copy _
Destination:=wrkSht.Cells(1, 1)
End If
'Increase the user name by 1 and search again.
UserNum = UserNum + 1
Loop While Not foundStart Is Nothing
End With
End Sub

For specific user names you could use the code below. Would be better to pass the user names as an argument though.

Sub Extract()
Dim UsrNames As Variant
UsrNames = Array("Me", "You", "Someone else")
With ThisWorkbook.Worksheets("Sheet1").Columns(1)
Dim UsrName As Variant
For Each UsrName In UsrNames
Dim foundStart As Range
Dim foundEnd As Range
'Find the first and last occurrence of the user name (xlNext, xlPrevious).
'Note - user names start on row 2, with heading on row 1.
'The search starts AFTER the first cell ( .Cells(1,1) )
Set foundStart = .Find(UsrName, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext)
Set foundEnd = .Find(UsrName, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious)
'If the range is found then create a new sheet and copy the data to it.
If Not foundStart Is Nothing Then
Dim wrkSht As Worksheet
Set wrkSht = ThisWorkbook.Worksheets.Add
wrkSht.Name = UsrName
.Range(foundStart, foundEnd).Resize(, 11).Copy _
Destination:=wrkSht.Cells(1, 1)
End If
Next UsrName
End With
End Sub

huangapple
  • 本文由 发表于 2023年4月4日 18:19:14
  • 转载请务必保留本文链接：https://go.coder-hub.com/75928195.html
  • cell
  • excel
  • freeze
  • range
  • vba
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定