Gibt es eine Möglichkeit, wiederkehrenden Code in eine Funktion zu platzieren, um von mehreren Subs in VBA aufgerufen zu werden

Question

Ich habe eine Reihe von Subs für verschiedene Kategorien in einer Tabelle, die ich in Excel erstellen. Jedes Sub hat seine eigenen Daten, die es aus verschiedenen flachen Dateien abruft, aber es hat alle die gleiche Endung, die jeden Wert in eine bestimmte Zelle platziert, basierend auf dem Kategorie-Header, auf den er in der Zeile und Spalte ausgerichtet ist. Alles andere ist also die if-Anweisung am Anfang. Gibt es eine Möglichkeit, diesen Codeblock in ein separates Sub oder eine Funktion oder etwas zu setzen und nur einen Aufruf in jedem anderen Sub zu haben, so dass ich ihn nicht ständig eingeben muss/wenn ich es ändern möchte, würde ich es tun muss es nur an einem Ort ändern? Hier ist ein Beispiel für den Code:

Dieser Teil ist am Anfang jedes Unter und Änderungen basierend auf den Zeilenkopf

Sub calccategory() 

    For k = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row 
     If Cells(k, 4) = "row 1" Then 

Dieser Teil ist der Teil I in einer Funktion oder Unter platzieren möchten, weil es wird jedes Mal

  Dim CWS As Worksheet 
      Workbooks(ThisBook).Activate 

      For j = 5 To 15 

       For g = 1 To ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column 

        If Cells(3, g) = "col1" Then 

         With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
          On Error Resume Next 
          CWS.Cells(k, g).Value = col1_n 
         End With 

        ElseIf Cells(3, g) = "col2" Then 

         With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
          On Error Resume Next 
          CWS.Cells(k, g).Value = col2_n 
         End With 

        ElseIf Cells(3, g) = "col3" Then 

         With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
          On Error Resume Next 
          CWS.Cells(k, g).Value = col3_n 
         End With 

        ElseIf Cells(3, g) = "col 4" Then 

         With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
          On Error Resume Next 
          CWS.Cells(k, g).Value = col4_n 
         End With 

        ElseIf Cells(3, g) = "col5" Then 

         With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
          On Error Resume Next 
          CWS.Cells(k, g).Value = col5_n 
         End With 

        End If 

       Next g 

       On Error GoTo 0 

      Next j 

dieser Teil würde mich wieder Teil des Endes jedes Unter und kein Teil dieser Funktion die gleiche sein ich will

 End If 

    Next k 

End Sub 

Answer 1

Nun, sollten Sie etwas tun ...

Option Explicit 


Public Sub CalCategoryInternal(ByVal str_col2 As String, _ 
          ByVal g As Long, _ 
          ByVal k As Long, _ 
          ByVal j As Long, _ 
          ByRef CWS As Worksheet) 


     With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
      On Error Resume Next 

      CWS.Cells(k, g).Value = str_col2 

      On Error GoTo 0 

     End With 

    End Sub 

Sub calccategory() 

    Dim k, ThisBook, j, g, col1_n, col2_n, col3_n, col4_n, col5_n 


    For k = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row 
     If Cells(k, 4) = "row 1" Then 

      Dim CWS As Worksheet 

      Workbooks(ThisBook).Activate 

      For j = 5 To 15 

       For g = 1 To ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column 
        If Cells(3, g) = "col1" Then 

         Call CalCategoryInternal("col1", g, k, j, CWS) 
'      With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
'       On Error Resume Next 
'       CWS.Cells(k, g).Value = col1_n 
'      End With 

        ElseIf Cells(3, g) = "col2" Then 
         Call CalCategoryInternal("col1", g, k, j, CWS) 
         With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
          On Error Resume Next 
          CWS.Cells(k, g).Value = col2_n 
         End With 

        ElseIf Cells(3, g) = "col3" Then 
         With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
          On Error Resume Next 
          CWS.Cells(k, g).Value = col3_n 
         End With 

        ElseIf Cells(3, g) = "col 4" Then 
         With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
          On Error Resume Next 
          CWS.Cells(k, g).Value = col4_n 
         End With 

        ElseIf Cells(3, g) = "col5" Then 
         With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
          On Error Resume Next 
          CWS.Cells(k, g).Value = col5_n 
         End With 

        End If 

       Next g 

       On Error GoTo 0 
      Next j 
     End If 
    Next k 


End Sub 

Vorsicht - das ist wirklich eine niedrige Qualität Code. Z.B. die "Dim" s auf der Oberseite sollten nicht auf diese Weise deklariert werden und du kannst sie weiter verbessern. Ich sehe nicht, wo Sie das Arbeitsblatt festlegen, also nehme ich an, dass dies nur ein kleiner Teil des Codes ist. Genieß es!

Answer 2

ja können Sie leicht haften bleiben, dass in seinem eigenen Unter, und Sie können durch K-Wert in sie als Argument übergeben, die wie folgt einfach aussehen:

Sub calccategory() 

For k = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row 
    If Cells(k, 4) = row 1" Then 
    Call newSub(k) 
    End If 
Next k 
End Sub 

Sub newSub(byval k as long) 
Dim CWS As Worksheet 

Workbooks(ThisBook).Activate 

For j = 5 To 15 

For g = 1 To ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column 
    If Cells(3, g) = "col1" Then 

With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
On Error Resume Next  
CWS.Cells(k, g).Value = col1_n  
End With 

ElseIf Cells(3, g) = "col2" Then  
    With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
    On Error Resume Next 
    CWS.Cells(k, g).Value = col2_n 
End With 

ElseIf Cells(3, g) = "col3" Then  
    With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
    On Error Resume Next  
    CWS.Cells(k, g).Value = col3_n  
End With 

ElseIf Cells(3, g) = "col 4" Then 
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
    On Error Resume Next  
    CWS.Cells(k, g).Value = col4_n  
End With 

ElseIf Cells(3, g) = "col5" Then 
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 
    On Error Resume Next  
CWS.Cells(k, g).Value = col5_n 
End With  

End If 

Next g 


    On Error GoTo 0 
    Next j 

end sub 

Sie auch mit einer select-Anweisung betrachten könnte und verschachteln Sie Ihre Select-Anweisung in Ihrem Bereich mit .. obwohl es nicht so aussieht, als ob Sie tatsächlich Ihre With-Anweisung referenzieren, so dass Sie es wahrscheinlich loswerden können.

Ich würde mich wundern, wo Sie Variablen bekommen "ThisBook" "col1_n"/"col2_n" ... Ursache Sie könnten in eine "Funktion oder Variable nicht definiert" Problem auftreten, es sei denn, Sie definieren sie entweder Modul breit oder bestanden sie als Argumente in die Funktion.

Sie definieren CWS auch nicht gleich, sodass Sie einen Objektfehler erhalten. was ist das, was ich davon ausgehe, dass die Fehler bei den nächsten Anweisungen weitergehen.

einige der Verbesserungen So könnte ähnlich aussehen:

Sub calccategory() 

    For k = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row 
     If Cells(k, 4) = "row 1" Then 
      Call newSub(k) 
     End If 
    Next k 

End Sub 
Sub newSub(ByVal k As Long) 
Dim CWS As Worksheet 
Set CWS = Workbooks(ThisBook).Sheets("mySheetName") 

For j = 5 To 15 
    On Error Resume Next 
    For g = 1 To ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column 
     If Cells(3, g) = "col1" Then 
      With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))  'still unused 
       CWS.Cells(k, g).Value = col1_n 
       Select Case Cells(3, g) 
        Case "col2" 
         CWS.Cells(k, g).Value = col2_n 
        Case "col3" 
         CWS.Cells(k, g).Value = col3_n 
        Case "col 4" 
         CWS.Cells(k, g).Value = col4_n 
        Case "col5" 
         CWS.Cells(k, g).Value = col5_n 
       End Select 
      End With 
     End If 
    Next g 
    On Error GoTo 0 
Next j 
End Sub 

Viel Glück!

Answer 3

Was Sie tun müssen, wie ich in einem Kommentar gepostet habe, sind die Argumente an das neue Sub. Außerdem haben Sie viel wiederkehrenden Code, also habe ich versucht, das zu verschärfen.

Sub calccategory() 
For k = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row 
    If Cells(k, 4) = "row 1" Then 
     theLoop k 
    End If 
Next k 
End Sub 

Sub theLoop(ByVal k As Integer) 
Dim CWS  As Worksheet 

Set CWS = Workbooks(ThisBook) 

For j = 5 To 15 
    With CWS 
     For g = 1 To .Cells(3, .Columns.Count).End(xlToLeft).Column 
      With .Range(.Cells(k, j * 4 + 2), .Cells(k + 1, j * 4 + 4)) 
       On Error Resume Next 
       If .Cells(3, g) = "col1" Then .Cells(k, g).Value = col1_n 
        ElseIf .Cells(3, g) = "col2" Then .Cells(k, g).Value = col2_n 
        ElseIf .Cells(3, g) = "col3" Then .Cells(k, g).Value = col3_n 
        ElseIf .Cells(3, g) = "col 4" Then .Cells(k, g).Value = col4_n 
        ElseIf .Cells(3, g) = "col5" Then .Cells(k, g).Value = col5_n 
      End If 
     End With 
    Next g 
End With      'CWS 
On Error GoTo 0 
Next j 
End Sub 

Answer 4

mittlerweile sind Sie weitere Informationen hinzufügen, ich kann in werfen, was folgt:

Option Explicit 

Sub calccategory() 
    Dim k As Long 
    Dim CWS As Worksheet 
    Dim col1_n As Variant, col2_n As Variant, col3_n As Variant, col4_n As Variant, col5_n As Variant 

    With ActiveSheet 
     For k = 1 To .Cells(Rows.Count, 4).End(xlUp).Row 
      If .Cells(k, 4) = "row 1" Then FillValues k, Workbooks("ThisBook").ActiveSheet, CWS, Array(col1_n, col2_n, col3_n, col4_n, col5_n) 
     Next k 
    End With 

End Sub 

Sub FillValues(k As Long, ws As Worksheet, CWS As Worksheet, colArray As Variant) 
    Dim j As Long, G As Long, col As Long 
    Dim strng As String 

    With ws 
'  For j = 5 To 15 '<--| I commented it since it seems not to be used anywhere, once removing that 'With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))' 
      For G = 1 To .Cells(3, .Columns.Count).End(xlToLeft).Column 
       strng = .Cells(3, G).Value2 
       If Left(strng, 3) = "col" Then 
        If IsNumeric(Mid(strng, 4, 1)) Then 
         col = CLng(Mid(strng, 4, 1)) 
         If col <= 5 Then CWS.Cells(k, G).Value = colArray(col - 1) 
        End If 
       End If 
      Next G 
'  Next j 
    End With 
End Sub 

aber es gibt viel, was Sie erklären sollte (ThisBook, CWS, With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))) um es zu verstehen!