Change the result in macro Excel 2003

Question

Hey guys i have a excel 2003 document with 9 sheets, 8 per parc and the 9 for the result.

Then I get how many GF , GP thah have every employer indicating the name, and parcnumber etc... in the result sheet executing a macro clicking "Obtener datos".

But now, i changed the Parcnumber to Parcname in every sheet and also,i changed the name of the sheet.

So when i did it, the macro doesnt'work or not appear nothing the result sheet.

I want get the next dates result:

My code is this:

 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

Then How can i get the parcname in the result sheet?

For a start, you are checking the names of the sheets for the pattern `"Parc*"` and therefore the code inside the loop is never executed - it's easy to figure this out using the debugger. — FunThomas, Mar 19 '18 at 08:34
Ye i know it, but i dont know that put for replace it because im new in va — kestrelol, Mar 19 '18 at 08:39

QHarr · Answer 1 · 2018-03-19T09:35:08.760

Focusing only on the name changes, I think there are other changes you should make, however, the general parts to focus on are as below.

Note: I have used a function to return the sheet names to loop over. These must be spelt the same in the sheet and as the sheet names i.e. same case, same accents, same spelling e.g. Calvia not Calvia and Calvià. Whilst the sentence case matching may not be essential I would consider it good practice. You can set MatchCase to False for the Find and use LookAt:=xlPart to get partial match but I would go with being specific. You should also consider using a check that all worksheets are present.

You can then use the sheet name in your find e.g. H.Name

I have included Private Sub SACAR·DATOS() as it references "PARC" but I am not sure what you will do with it. I can amend this with further information but you should be aware of this and review.

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

When i change "For Each H In Worksheets" to "For Each H In ThisWorkbook.Worksheets(GetParcNames)" and "fu = .Range("A:A").Find("Parc").Row + 1" to "fu = .Range("A:A").Find(H.Name).Row + 1" Doesn't work : "ReDim M(Q, 12) ERROR". Because Q is used in "Q = Q + (uf - fu + 1) * 31" — kestrelol, Mar 19 '18 at 11:42
I am only giving you the skeleton part. Does each H.Name value appear in the worksheet of the same name in the column A? Same spelling, same accents? — QHarr, Mar 19 '18 at 12:14
The accent is only in the sheet name in "Calvià" and "Artà", but inside of both, don't have it. I was confusing sorry in my result sheet because i have put the accent manually, but don't need it. Anyway, I can remove the accent in sheet name. Can you give me all the code without errors, without accents,.? — kestrelol, Mar 19 '18 at 12:27
not without the actual workbook as there is lots going on. But the key is that you must have the same spellings in the sheet as per the sheet names or you will get an error. The code I have posted will work to loop sheets and find the value if it exists as specified. — QHarr, Mar 19 '18 at 13:13

Change the result in macro Excel 2003

1 Answers1