在宏Excel 2003中更改結果

Question

大家好，我有一個Excel 2003文檔，其中有9張紙，每張紙8張，結果9張。

然后，我在結果表中單擊“ Obtener datos”執行宏，得到多少GF，GP thah每個雇主都標明姓名和parcnumber等。

但是現在，我在每個工作表中都將Parcnumber更改為Parcname，並且還更改了工作表的名稱。

因此，當我這樣做時，宏不起作用或在結果表中不顯示任何內容。

我想獲得下一個日期的結果：

我的代碼是這樣的：

 Option Explicit
Option Base 1
Option Compare Text

Dim M(), fm&
Dim R, fr&, fu%, uf&, fila&
Dim Q&, i%, j%, arr
Dim fecha&, DD%, MM%, YY%
Dim G%, GR%, GP%, GF%, GC%, GE%, GRC%, GPC%, GFC%, COLUMNA%, QG$


Sub OBTENER·NUM·REG()

Dim H As Worksheet
Dim S As Worksheet
fm = 0
arr = Array("January", "February", "March", "April", "May", "June", "July", _
             "August", "September", "October", "November", "December")
Q = 0
For Each H In Worksheets
   If H.Name Like "Parc*" Then
      With H
         fu = .Range("A:A").Find("Parc").Row + 1
         uf = .Range("A" & Rows.Count).End(xlUp).Row
          Q = Q + (uf - fu + 1) * 31
          For i = 1 To 12
            If arr(i) = .Range("a2") Then
               YY = Year(Now)
               MM = Month(CDate("01/" & i & "/" & YY))
               Exit For
            End If
          Next
      End With
   End If
Next

ReDim M(Q, 12)
For Each H In Worksheets
   If H.Name Like "Parc*" Then
      With H
         fu = .Range("A:A").Find("Parc").Row + 1
         uf = .Range("A" & Rows.Count).End(xlUp).Row
         Set R = .Range(.Cells(fu, 1), .Cells(uf, 129))
         For fr = 1 To R.Rows.Count
            fila = R(fr, 1).Row
            If Len(Trim(R(fr, 1))) > 0 Then
               For i = 6 To 126 Step 4
                  For j = i To i + 3
                     QG = .Cells(fila, j)
                     Select Case QG
                        Case "G":  G = G + 1: COLUMNA = 4: GoSub REGISTRAR·DATO: Exit For
                        Case "GR": GR = GR + 1: COLUMNA = 5: GoSub REGISTRAR·DATO: Exit For
                        Case "GP":  GP = GP + 1: COLUMNA = 6: GoSub REGISTRAR·DATO: Exit For
                        Case "GF":  GF = GF + 1: COLUMNA = 7: GoSub REGISTRAR·DATO: Exit For
                        Case "GC":  GC = GC + 1: COLUMNA = 8: GoSub REGISTRAR·DATO: Exit For
                        Case "GE": GE = GE + 1: COLUMNA = 9: GoSub REGISTRAR·DATO: Exit For
                        Case "GRC":  GRC = GRC + 1: COLUMNA = 10: GoSub REGISTRAR·DATO: Exit For
                        Case "GPC":  GPC = GPC + 1: COLUMNA = 11: GoSub REGISTRAR·DATO: Exit For
                        Case "GFC":  GFC = GFC + 1: COLUMNA = 12: GoSub REGISTRAR·DATO: Exit For
                     Stop
                     End Select
                  Next
               Next
            End If
         Next
      End With
   End If
Next

SACAR·DATOS
ORDENAR·DATOS
Exit Sub

REGISTRAR·DATO:

'Stop
fm = fm + 1
M(fm, 1) = H.Cells(fila, 1)
M(fm, 2) = H.Name
M(fm, 3) = CDbl(CDate(H.Cells(4, i) & "/" & MM & "/" & YY))
M(fm, COLUMNA) = 1
Return

End Sub

Private Sub SACAR·DATOS()
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Result").Select
On Error GoTo 0
Cells.ClearContents
Range("A1").Resize(, 12) = Array("NOM", "PARC", "DATA", "G", "GR", "GP", "GF", "GC", "GE", "GRC", "GPC", "GFC")
Range("A1").Resize(, 12).Font.Bold = True
Range("C2").Resize(fm).NumberFormat = "DD/MM/YYYY"
MsgBox "Continuar ..."
Application.ScreenUpdating = False
Range("A2").Resize(fm, 12) = M
Range("A:F").Columns.AutoFit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Cells(1, 1).Select
ActiveWindow.ScrollRow = ActiveCell.Row
End Sub
Private Sub ORDENAR·DATOS()
Dim R As Range, fr&
   Set R = Range("a1").CurrentRegion
Dim Q&
   Q = R.Rows.Count
    ActiveWorkbook.Worksheets("Result").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Result").Sort.SortFields.Add Key:=Range("B2:B" & Q), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Result").Sort.SortFields.Add Key:=Range("A2:A" & Q), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Result").Sort.SortFields.Add Key:=Range("C2:C" & Q), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Result").Sort
        .SetRange Range("A1:F" & Q)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

For fr = 3 To R.Rows.Count
   If R(fr, 1) & R(fr, 2) = R(fr - 1, 1) & R(fr - 1, 2) Then
      R(fr, 1) = ""
      R(fr, 2) = ""
      fr = fr + 1
   End If
Next
End Sub

然后，如何在結果表中獲取parcname？

Answer 1

我只關注名稱更改，我認為您還應該進行其他更改，但是，要關注的一般部分如下。

注意：我使用了一個函數來返回工作表名稱以進行循環。 這些名稱在工作表中的拼寫必須與工作表名稱的拼寫相同，即大小寫相同，重音符號相同，拼寫相同，例如Calvia not Calvia和Calvià 。 雖然句子大小寫匹配可能不是必需的，但我認為這是一種很好的做法。 您可以設置MatchCase以False的發現和使用LookAt:=xlPart獲得部分比賽，但我會為特定去。 您還應該考慮檢查所有工作表是否都存在 。

然后，您可以在查找中使用工作表名稱，例如H.Name

我已經包含了Private Sub SACAR·DATOS（），因為它引用了“ PARC”，但是我不確定您將如何處理它。 我可以使用更多信息來對此進行修改，但是您應該對此有所了解並進行審查。

Sub OBTENER·NUM·REG()

    Dim H As Worksheet

    For Each H In ThisWorkbook.Worksheets(GetParcNames)

        With H
            fu = .Range("A:A").Find(H.Name).Row + 1

        End With

    Next H

End Sub

Private Sub SACAR·DATOS()

    Range("A1").Resize(, 12) = Array("NOM", "PARC", "DATA", "G", "GR", "GP", "GF", "GC", "GE", "GRC", "GPC", "GFC")

End Sub


Public Function GetParcNames() As Variant

    GetParcNames = Array("Calvia", "Inca", "Manacor", "Soller", "Alcudia", "Felantix", "Arta", "Llucjmajor") 'spelling and accents must be same for sheet names and in sheet as are spelt here

End Function