更改宏 Excel 2003 中的结果

Question

大家好，我有一个 Excel 2003 文档，包含 9 张，每包 8 张，结果为 9。

然后我得到多少 GF ， GP thah 每个雇主都标明了姓名，parcnumber 等...在结果表中执行一个宏，点击“Obtener datos”。

但是现在，我在每张纸上都将 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 不是 Calvia 和 Calvià。虽然句子大小写匹配可能不是必需的，但我认为这是一种很好的做法。您可以将 MatchCase 设置为 False 以进行查找并使用 LookAt:=xlPart 获得部分匹配，但我会更具体。您还应该考虑使用检查所有worksheets are present。

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

我已包含 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