VBA-Forum - Das Forum zu Microsoft VBA

VBA Excel VBA Word VBA Access VBA VBScript VB C# Objective-C C++ SQL JAVA VBA (English) Jobs Übersicht

Thema	Datum	Von Nutzer	Rating	Antwort
Werte in einem bestimmten Registerblatt erst ab Zeile 4 einfügen	19.09.2014 23:00:57	Stefan
Werte in einem bestimmten Registerblatt erst ab Zeile 4 einfügen	20.09.2014 02:39:49	Gast51893
Werte in einem bestimmten Registerblatt erst ab Zeile 4 einfügen	20.09.2014 18:37:24	Gast95220

Ansicht des Beitrags:

Von:
Stefan

Datum:
19.09.2014 23:00:57

Views:
3019

Rating:

Antwort:

Thema:
Werte in einem bestimmten Registerblatt erst ab Zeile 4 einfügen

Hallo zusammen,

Ein Kollege hat mir ein Makro erstellt (für einige Wochen nicht erreichbar), das die Daten, die sich allesamt in einem Excel-Registerblatt (Exportdaten) befinden, sortiert nach entsprechender Fertigungswoche auf die entsprechenden Arbeitsplätze aufteilt, für die jeweils eigene Registerblätter existieren. Soweit so gut. Jedes der Registerblätter hat in Zeile 1 und 2 Überschriften. Die Daten werden vom Blatt Exportdaten also grundsätzlich erst in die 3. Zeile der übrigen Registerblätter übertragen (siehe: ProcessDataWithID).

Registerblatt "Service" (siehe: ProcessDataWithID2) benötigt nun aber eine weitere Überschriftszeile, folglich sollen die Daten hier erst ab Zeile 4 übertragen werden. Der Quellcode ist entsprechend umfangreich, deshalb bin ich etwas unsicher, welche Bestandteile diejenigen sind die relevant sind:

Private Sub ProcessDataWithID(sWorksheet As String, lStartRow As Long, lEndRow As Long, lColumn As Long, iProcessID As Integer, iNoDuplicates As Integer)
  Dim lRow As Long
  Dim sActYearWeek As String
  Dim sNextYearWeek As String
  Dim sWeek As String
  Dim bCopy As Boolean
  Dim lNoDuplicatesRowActWeek As Long
  Dim lNoDuplicatesRowNextWeek As Long

  ' Jahr & Woche zusammensetzen
  sWeek = Right(Str(iActWeek), 2)
  If Left(sWeek, 1) = " " Then
    sWeek = "0" + Right(sWeek, 1)
  End If
  sActYearWeek = Right(Val(iActYear), 4) & sWeek
  
  sWeek = Right(Str(iNextWeek), 2)
  If Left(sWeek, 1) = " " Then
    sWeek = "0" + Right(sWeek, 1)
  End If
  sNextYearWeek = Right(Val(iNextYear), 4) & sWeek

  ' Arbeitsbereich für NoDuplicates bestimmen
  If iNoDuplicates = True Then
    lNoDuplicatesRowActWeek = 3
    lNoDuplicatesRowNextWeek = 3
  End If
  If iNoDuplicates = iProcessID Then
    lNoDuplicatesRowActWeek = lDestRowActWeek
    lNoDuplicatesRowNextWeek = lDestRowNextWeek
  End If

  lRow = lStartRow
  Do
    ' keine Testwalzen
    If oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 3).Value <> "" Or _
       oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 5).Value <> "" Or _
       oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value <> "" Or _
       (oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 8).Value <> 0 And _
        oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 8).Value <> "") Or _
       oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 10).Value <> 0 Then
  
      ' Werte für die aktuelle Woche
      If oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 1).Value = sActYearWeek Then
        If GetProcessID(lRow) = iProcessID Then
          bCopy = True
          If iNoDuplicates = iProcessID Or iNoDuplicates = True Then
            If CheckDuplicateEntry(sWorksheet, lNoDuplicatesRowActWeek, 1, lRow) = True Then
              bCopy = False
            End If
          End If
                                   
          ' Sonderprüfung für Arbeitsplatz 340 und "Service generell"
          If sWorksheet = sWorksheet_Serviceold Then
            If oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 6).Value = "Service generell" And oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 13).Value = "" Then
              bCopy = False
            End If
          End If
          If bCopy = True Then
            oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 1).Interior.ColorIndex = 36
            oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 1).Interior.Pattern = xlSolid
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 1).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 2).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 2).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 3).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 3).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 4).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 4).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 5).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 5).Value = Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value, 1, 2) & " " & Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value, 3, 2) & " " & Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value, 5)
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 6).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 8).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 7).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 10).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 8).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 11).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 9).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 12).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 10).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 13).Value
            If iNoDuplicates = False Then
              oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 10).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 6).Value
            End If
            ' Sonderprüfung für Arbeitsplatz 340 und "Service generell"
            If sWorksheet = sWorksheet_Serviceold Then
              If oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 6).Value <> "Service generell" Then
                oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 10).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 6).Value
              End If
            End If
            ' Sonderprüfung für Arbeitsplatz 240
            If sWorksheet = sWorksheet_Konfektion Then
              If InStr(1, oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 16).Value, "R01") Then
                oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 11).Value = "Gummi vorhanden"
              End If
              If InStr(1, oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 16).Value, "R02") Then
                oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 11).Value = "Wird in Mischerei gefertigt"
              End If
              If InStr(1, oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 16).Value, "R03") Then
                oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 11).Value = "Gummi ist bestellt"
              End If
            End If
            ' Sonderprüfung für Arbeitsplatz 251/252
            If sWorksheet = sWorksheet_PUuCC Then
              If InStr(1, oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 16).Value, "C01") Then
                oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 11).Value = "Harz-Mischung vorhanden"
              End If
              If InStr(1, oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 16).Value, "C02") Then
                oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 11).Value = "Wird in CC-Mischerei gefertigt"
              End If
            End If
            
            lDestRowActWeek = lDestRowActWeek + 1
          End If
        End If
      End If
      
      ' Werte für die folgende Woche
      If oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 1).Value = sNextYearWeek Then
        If GetProcessID(lRow) = iProcessID Then
          bCopy = True
          If iNoDuplicates = iProcessID Or iNoDuplicates = True Then
            If CheckDuplicateEntry(sWorksheet, lNoDuplicatesRowNextWeek, lColumn, lRow) = True Then
              bCopy = False
            End If
          End If
          ' Sonderprüfung für Arbeitsplatz 340 und "Service generell"
          If sWorksheet = sWorksheet_Serviceold Then
            If oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 6).Value = "Service generell" And oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, lColumn + 2).Value = "" Then
              bCopy = False
            End If
          End If
          If bCopy = True Then
            oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 1).Interior.ColorIndex = 40
            oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 1).Interior.Pattern = xlSolid
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 2).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn + 1).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 3).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn + 2).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 4).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn + 3).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 5).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn + 4).Value = Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value, 1, 2) & " " & Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value, 3, 2) & " " & Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value, 5)
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn + 5).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 8).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn + 6).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 10).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn + 7).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 11).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn + 8).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 12).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn + 9).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 13).Value
            If iNoDuplicates = False Then
              oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn + 9).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 6).Value
            End If
            ' Sonderprüfung für Arbeitsplatz 340 und "Service generell"
            If sWorksheet = sWorksheet_Serviceold Then
              If oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 6).Value <> "Service generell" Then
                oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn + 9).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 6).Value
              End If
            End If
            ' Sonderprüfung für Arbeitsplatz 240
            If sWorksheet = sWorksheet_Konfektion Then
              If InStr(1, oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 16).Value, "R01") Then
                oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, lColumn + 10).Value = "Gummi vorhanden"
              End If
              If InStr(1, oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 16).Value, "R02") Then
                oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, lColumn + 10).Value = "Wird in Mischerei gefertigt"
              End If
              If InStr(1, oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 16).Value, "R03") Then
                oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, lColumn + 10).Value = "Gummi ist bestellt"
              End If
            End If
            ' Sonderprüfung für Arbeitsplatz 251/252
            If sWorksheet = sWorksheet_PUuCC Then
              If InStr(1, oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 16).Value, "C01") Then
                oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, lColumn + 10).Value = "Harz-Mischung vorhanden"
              End If
              If InStr(1, oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 16).Value, "C02") Then
                oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, lColumn + 10).Value = "Wird in CC-Mischerei gefertigt"
              End If
            End If
            
            lDestRowNextWeek = lDestRowNextWeek + 1
          End If
        End If
      End If
    End If
    
    If lRow > lEndRow Then
      Exit Do
    End If
    lRow = lRow + 1
  Loop
End Sub

Private Sub ProcessDataWithID2(sWorksheet As String, lStartRow As Long, lEndRow As Long, lColumn As Long, iProcessID As Integer, iNoDuplicates As Integer)
  Dim lRow As Long
  Dim sActYearWeek As String
  Dim sNextYearWeek As String
  Dim sWeek As String
  Dim lDestRow As Long
  Dim lDestColumn As Long

  ' Jahr & Woche zusammensetzen
  sWeek = Right(Str(iActWeek), 2)
  If Left(sWeek, 1) = " " Then
    sWeek = "0" + Right(sWeek, 1)
  End If
  sActYearWeek = Right(Val(iActYear), 4) & sWeek
  
  sWeek = Right(Str(iNextWeek), 2)
  If Left(sWeek, 1) = " " Then
    sWeek = "0" + Right(sWeek, 1)
  End If
  sNextYearWeek = Right(Val(iNextYear), 4) & sWeek
  
  lRow = lStartRow
  Do
    ' keine Testwalzen
    If oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 3).Value <> "" Or _
       oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 5).Value <> "" Or _
       oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value <> "" Or _
       (oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 8).Value <> 0 And _
        oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 8).Value <> "") Or _
       oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 10).Value <> 0 Then
  
        ' Werte für die aktuelle Woche
      If oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 1).Value = sActYearWeek Then
        lDestColumn = GetEntryColumn(lRow)
        If lDestColumn <> -1 Then
          lDestColumn = lDestColumn + 2
          
          oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 1).Interior.ColorIndex = 36
          oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 1).Interior.Pattern = xlSolid
          
          lDestRow = GetEntryRow(sWorksheet, 3, 1, lRow)
          If lDestRow = -1 Then
            lDestRow = lDestRowActWeek
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 1).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 5).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowActWeek, 2).Value = Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value, 1, 2) & " " & Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value, 3, 2) & " " & Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value, 5)
            lDestRowActWeek = lDestRowActWeek + 1
          End If
          
          oWorkbook.Worksheets(sWorksheet).Cells(lDestRow, lDestColumn).Value = "X"
        End If
      End If
      
      ' Werte für die folgende Woche
      If oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 1).Value = sNextYearWeek Then
        lDestColumn = GetEntryColumn(lRow)
        If lDestColumn <> -1 Then
          lDestColumn = lDestColumn + lColumn + 1
          
          oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 1).Interior.ColorIndex = 40
          oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 1).Interior.Pattern = xlSolid
          
          lDestRow = GetEntryRow(sWorksheet, 3, lColumn, lRow)
          If lDestRow = -1 Then
            lDestRow = lDestRowNextWeek
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn).Value = oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 5).Value
            oWorkbook.Worksheets(sWorksheet).Cells(lDestRowNextWeek, lColumn + 1).Value = Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value, 1, 2) & " " & Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value, 3, 2) & " " & Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lRow, 7).Value, 5)
            lDestRowNextWeek = lDestRowNextWeek + 1
          End If
          
          oWorkbook.Worksheets(sWorksheet).Cells(lDestRow, lDestColumn).Value = "X"
        End If
      End If
    End If
  
    If lRow > lEndRow Then
      Exit Do
    End If
    lRow = lRow + 1
  Loop
End Sub

Füge euch abschließend noch den Codebestandteil GetEntryRow ein. Hoffe, hier sind die notwendigen Informationen zu finden. Weiß im Moment nicht weiter und habe schon stundenlang etwas probiert.

Private Function GetEntryRow(sWorksheet As String, lStartRow As Long, lColumn As Long, lReferenceRow As Long) As Long
  Dim lRow As Long
  Dim iCount As Integer
  
  lRow = lStartRow
  Do
    If oWorkbook.Worksheets(sWorksheet).Cells(lRow, lColumn).Value = "" Then
      iCount = iCount + 1
    Else
      iCount = 0
      If oWorkbook.Worksheets(sWorksheet).Cells(lRow, lColumn + 1).Value = Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lReferenceRow, 7).Value, 1, 2) & " " & Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lReferenceRow, 7).Value, 3, 2) & " " & Mid(oWorkbook.Worksheets(sWorksheet_Exportdaten).Cells(lReferenceRow, 7).Value, 5) Then
        GetEntryRow = lRow
        Exit Function
      End If
    End If
    
    If iCount >= 10 Then
      Exit Do
    End If
    lRow = lRow + 1
  Loop
  
  ' nichts gefunden
  GetEntryRow = -1
End Function



Vielen Dank!

Stefan

Ihre Antwort

Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema:		Name:		Email:

Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema	Datum	Von Nutzer	Rating	Antwort
Werte in einem bestimmten Registerblatt erst ab Zeile 4 einfügen	19.09.2014 23:00:57	Stefan
Werte in einem bestimmten Registerblatt erst ab Zeile 4 einfügen	20.09.2014 02:39:49	Gast51893
Werte in einem bestimmten Registerblatt erst ab Zeile 4 einfügen	20.09.2014 18:37:24	Gast95220