VBA日付と他の識別子に基づく値ループの返却

Question

私は支払承認リクエストを自動化する必要があるいくつかの作業を行っていますが、私は複数の支払いを伴う支払い要求に対して2つの識別子があるという問題があります。リンゴの旗で4回、バナナで5回の支払いをする。マクロは、今日の支払い日付ですべての支払いを検索し、この支払いがリンゴまたはバナナの支払いであるかどうかを判断する必要があります。それは今日のすべての支払いを両方のためにコピーし、別のシートに貼り付けます。

日付識別子がソースデータシートのセルA2にあり、日付がセルF4からF2000にあり、リンゴ/バナナフラグがG4からG2000にあるとします。

セルH4からH2000への支払いの価値を、Appleの支払いタブまたはバナナ支払タブにセルI4からI2000の一意の参照番号と共に貼り付けるとします。

私はここで見つけたものを使用しようとしましたが、本当に苦労しています。

Sub Fruit() 
    Dim lastRow As Long 
    Dim lastTRow As Long 'Last Target Row 
    Dim tRow As Long  'Target Row 
    Dim source As String 'The source sheet 
    Dim target As String 'Variable target sheet 
    Dim tempVal As String 'Hold value of Source!B2 
    Dim ws As Worksheet 

    source = "Source Data" 
    lastRow = Sheets("Source Data").Range("D" & Rows.Count).End(xlUp).Row 

    For lRow = 3 To lastRow     'Loop through source sheet 
     tempVal = Sheets("Source Data").Cells(lRow, "D").Text 
     If Sheets("Source Data").Cells(lRow, "F").Value = tempVal Then 
      Sheets("Source Data").Cells(lRow, "I").Copy 
      lastTRow = Sheets("Banana").Range("C" & "70").End(xlUp).Row   'Get Last Row 
      tRow = lastTRow + 1    'Set new Row 1 after last 
      'tRow.Select.Paste 
      'Copy cells from one sheet to another loop columns 
      Sheets("Banana").Cells(tRow, "C").PasteSpecial 
     End If 
    Next lRow 
End Sub 

Answer 1

あなたのコードは、あなたが記述したものと完全に一致していないので、私はあなたの説明に行った。文が欠落している場合、列Hの値が

二コピーされていません

• は、バナナやリンゴスプレッドシート

Iのいずれかの値を代入します。あなたのコードを持ついくつかの問題があります。あなたのコードを更新してHのフラグをチェックし、次にHとIの値をC & Dに移動させて、フラグに基づいてアップルワークシートまたはバナナワークシートのいずれかに入れます：

Sub Fruit() 

Dim lastRow As Long 
Dim lastRowData As Long, lastRowApples As Long, lastRowBananas As Long 'Last Target Row 
Dim tRow As Long  'Target Row 
Dim tempVal As String 'Hold value of Source!B2 
Dim wsSource As Worksheet, wsApples As Worksheet, wsBananas As Worksheet 

Set wsSource = ThisWorkbook.Sheets("Source Data") 
Set wsApples = ThisWorkbook.Sheets("Apples") 
Set wsBananas = ThisWorkbook.Sheets("Bananas") 

lastRowData = wsSource.Range("D" & Rows.Count).End(xlUp).Row 

    For lRow = 3 To lastRowData 'Loop through source sheet 
     If wsSource.Range("D" & lRow).Value = wsSource.Range("F" & lRow).Value Then 
      If wsSource.Range("G" & lRow).Value = "Apples" Then ' check for apple flag in column G 
       wsSource.Range("H" & lRow & ":I" & lRow).Copy wsApples.Range("C" & wsApples.Range("C" & Rows.Count).End(xlUp).Row + 1) 'Copy Cells H&I in Cells C:D in the sheet 
      ElseIf wsSource.Range("G" & lRow).Value = "Bananas" Then ' check for banana flag in column G 
       wsSource.Range("H" & lRow & ":I" & lRow).Copy wsBananas.Range("C" & wsBananas.Range("C" & Rows.Count).End(xlUp).Row + 1) 'Copy Cells H&I in Cells C:D in the sheet 
      End If 
     End If 
    Next lRow 

End Sub 

Answer 2

この

Option Explicit 

Sub Fruit() 
    With Sheets("Source Data") 
     With .Range("I3", .Cells(.Rows.count, "F").End(xlUp)) 
      .AutoFilter Field:=1, Operator:=xlFilterValues, Criteria2:=Array(2, .Parent.Range("A2").Value) 
      FilterAndCopy .Cells, "banana", "Banana Payment" 
      FilterAndCopy .Cells, "apple", "Apples Payment" 
     End With 
     .AutoFilterMode = False 
    End With 
End Sub 

Sub FilterAndCopy(rng As Range, filterValue As String, destShtName As String) 
    With rng 
     .AutoFilter Field:=2, Criteria1:=filterValue 
     If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then .Resize(.Rows.count - 1, 2).Offset(, 2).SpecialCells(xlCellTypeVisible).Copy Worksheets(destShtName).Range("A1") 
    End With 
End Sub