VBA：如何找到部门并将其替换为其他部门？

Question

我很难找到解决这个问题的方法。我正在尝试找到字符串department并将其替换为另一个部门。每个工作簿中有 16-10张需要格式化。其中一种格式需要移动/复制first department string（在某些行中延伸到columns B,C）并将其粘贴到last department所在的位置，但是columnA中的第一个部门member number 1}}除了 Sub format() Dim ws As Worksheet Dim frstDept As Long Dim lastDept As Long Dim rng As Long Dim n As Long Dim nlast As Long Dim rw As Range Dim i As Integer Dim iVal As Integer iVal = Application.WorksheetFunction.CountIf(Range("A1:A20000"), "Department") Debug.Print iVal Set rw = ActiveWorkbook.ActiveSheet.UsedRange.Rows nlast = rw.Count For Each ws In Sheets On Error GoTo NextWS For i = iVal To 1 Step -1 With ws frstDept = Range("A:A").Find(What:="Department", LookIn:=xlValues, LookAt:=xlPart).Row lastDept = Range("A:A").Find(What:="Member Number", LookIn:=xlValues, LookAt:=xlPart).Row If .frstDept.Value = .lastDept.Value Then frstDept.Selection.Offset(0, 2).Cut Destination:=Range("lastDept" + 1).Resize(1) End If End If End With NextWS: Err.Clear Next ws End Sub 之外没有一个部门。原因在于它使该部门成为一个头衔。

底部的图片应提供更多信息。

这是我到目前为止所做的，但并不符合。我将不胜感激。 请提出问题并提出建议。谢谢。

{{1}}

Answer 1

我相信以下代码可行：

Sub format()
    Dim ws As Worksheet
    Dim r As Long
    Dim lastDept As String
    Dim nextDept As String
    Dim rw As Long

    For Each ws In Worksheets ' Changed from "Sheets" to "Worksheets" to avoid
                              ' problems if any "Charts" exist
        With ws
            rw = .Cells(.Rows.Count, "A").End(xlUp).Row
            'Grab the details of the last "Department" and then clear the cells
            lastDept = RTrim(.Cells(rw, "A") & .Cells(rw, "B") & .Cells(rw, "C"))
            .Range("A" & rw & ":C" & rw).ClearContents

            For r = rw To 2 Step -1
                If Trim(.Cells(r, "A").Value) = "MEMBER NUMBER" Then
                    nextDept = RTrim(.Cells(r - 1, "A") & .Cells(r - 1, "B") & .Cells(r - 1, "C"))
                    .Range("A" & r - 1 & ":C" & r - 1).ClearContents
                    .Cells(r - 1, "A").Value = lastDept
                    lastDept = nextDept
                End If
            Next
        End With
    Next ws
End Sub

每次发现＆＃34;会员号码＆＃34;在A列中，它从上面一行的A：C列中获取信息，然后清除这些单元格，并用前一次遇到＆＃34;成员编号＆＃34;的连接值替换A列。 （我假设将A：C列连接成一个字符串是一件好事。如果没有，我可以编辑它以便将值保存为单独的字符串。）

编辑搜索＆＃34;部门＆＃34; （依赖第1行始终为空白）。

Sub format()
    Dim ws As Worksheet
    Dim r As Long
    Dim lastDept As String
    Dim nextDept As String
    Dim rw As Long

    'Initialise "lastDept" to blank so that the first replacement we make
    '(i.e. the one on the last row) is to an empty value        
    lastDept = ""
    'Loop through every worksheet
    'Use "Worksheets" collection rather than "Sheets" collection so that
    'we don't try to do any processing on Charts ("Sheets" contains both
    'Worksheet and Chart objects)
    For Each ws In Worksheets
        'Use a "With" block so that we don't have to constantly write
        '"ws.Cells", "ws.Range", "ws.Rows", etc - we can just use
        '".Cells", ".Range", ".Rows", etc instead
        With ws
            'Find the end of the data by finding the last non-empty cell in column A
            rw = .Cells(.Rows.Count, "A").End(xlUp).Row
            'Loop (backwards) through each row in the worksheet
            For r = rw To 1 Step -1
                'We only need to process something when Column A starts with
                '"Department", or if this is row 1 (which will be empty)
                If Left(.Cells(r, "A").Value, 10) = "Department" Or r = 1 Then
                    'Temporarily store the current values of this row's columns A:C
                    'Join all three cells into one string to make it look "nicer"
                    nextDept = RTrim(.Cells(r, "A").Value & _
                                     .Cells(r, "B").Value & _
                                     .Cells(r, "C").Value)
                    'Clear out what was in A:C
                    .Range("A" & r & ":C" & r).ClearContents
                    'Write the contents of "lastDept" into column A
                    .Cells(r, "A").Value = lastDept
                    'Change "lastDept" to be the value which we stored in our
                    'temporary variable "nextDept" (The temporary variable was
                    'needed because, by the time we get to this line, we have
                    'written over the top of the information in the worksheet
                    'cells.)
                    lastDept = nextDept
                End If
            Next ' end of processing of a row
        End With
    Next ws ' end of processing of a Worksheet
End Sub

Answer 2

您将frstDept设置为一行，与lastDept相同。我相信你打算将它们设置为一个范围。试试这个：

Sub format()

   Dim ws As Worksheet
   Dim frstDept As Range
   Dim lastDept As Range
   Dim rng As Long
   Dim n As Long
   Dim nlast As Long
   Dim rw As Range
   Dim i As Integer
   Dim iVal As Integer


    Set rw = ActiveWorkbook.ActiveSheet.UsedRange.Rows
    nlast = rw.Count

    For Each ws In Sheets
        ws.Activate

        iVal = Application.WorksheetFunction.CountIf(ws.Range("A:A"), "*Department*") 
        Debug.Print iVal
        On Error GoTo NextWS
        For i = iVal To 1 Step -1 ' You dont have a next statement closing this for loop.
            With ws
                    Set frstDept = Range("A:A").Find(What:="Department", LookIn:=xlValues, LookAt:=xlPart)
                    Set lastDept = Range("A:A").Find(What:="Department", LookIn:=xlValues, LookAt:=xlPart)
                        If .frstDept.Value = .lastDept.Value Then
                            lastDept.Offset(-1, 0).Value = frstDept.Offset(1, 0).Value

                        End If
                    End If
            End With
 NextWS:
            Err.Clear

            Next ' This should close the for loop for your iVal iteration.
        Next ws

   End Sub

此外，您的两个查找语句都是相同的，理论上应该返回相同的范围。我无法理解为什么你在问题中使用相同的查找语句，所以我没有提出如何改进它的建议。

上面的代码可能无法解决您的问题，但它应该让您更接近。我最好的选择是，每当你试图获得firstdept和lastdept变量的值时，你的On Error语句就会被激活，所以它没有做任何事情。

我希望这会有所帮助。