Question

嘿伙计们，我有一份excel 2003文件，包含9张，每张parc 8张，结果为9张。

然后我得到有多少GF，GP让每个雇主都指出名字，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.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

在宏Excel 2003中更改结果

1 个答案: