VBA循環/邏輯問題

Question

我正在寫一個工作在excel中的宏，我遇到了麻煩。在這種情況下，有兩張表，「BU」和「TOPS信息」。當使用宏時，應該搜索「BU」的每一行以獲得「TOPS Information」中找到的值，然後進入「TOPS Information」的下一行並重復該過程。如果找到了正確的匹配，複製單元格並將其粘貼到「TOPS信息」

這裏是代碼：

Sub QIM() 

Dim j As Integer 
Dim k As Integer 
Dim i As Integer 
Dim l As Integer 
Dim m As Integer 

Dim searchArray(1 To 3) As String 

j = 0 
k = 1 



'WARNING: Temporary Sheet Names 
lastRowTOPS = Worksheets("TOPS Information").Cells(Rows.Count, "A").End(xlUp).Row 
lastRowBU = Worksheets("BU").Cells(Rows.Count, "A").End(xlUp).Row 

'Cycle through BU rows 
For j = lastRowTOPS To 1 Step -1 

    'Cycle through searchArray for each BU row 
    For k = lastRowBU To 1 Step -1 


      '////////////////////////////////////// 

      x = Sheets("BU").Range("B" & k).Value 
      y = Range("C" & j).Value 

      If StrComp(x, y) = 1 Then 



       Sheets("BU").Range("C" & k).Copy 
       Range("H" & j).PasteSpecial 



      End If 

      '////////////////////////////////////// 



    Next k 

Next j 


End Sub 

這如果「TOPS信息」在時間選擇的任何和所有幫助將宏顯然只適用。感謝！感謝！

Answer 1

你自己回答它自己。範圍指的是當前工作表，但是當你彈跳時，你必須限定它。

前綴的範圍，象這樣適當的紙張，

Sub QIM() 

    Dim j As Integer 
    Dim k As Integer 
    Dim i As Integer 
    Dim l As Integer 
    Dim m As Integer 

    Dim searchArray(1 To 3) As String 

    j = 0 
    k = 1 



    'WARNING: Temporary Sheet Names 
    lastRowTOPS = Worksheets("TOPS Information").Cells(Rows.Count, "A").End(xlUp).Row 
    lastRowBU = Worksheets("BU").Cells(Rows.Count, "A").End(xlUp).Row 

    'Cycle through BU rows 
    For j = lastRowTOPS To 1 Step -1 

     'Cycle through searchArray for each BU row 
     For k = lastRowBU To 1 Step -1 
       '////////////////////////////////////// 
       x = Sheets("BU").Range("B" & k).Value 
       y = Sheets("TOPS Information").Range("C" & j).Value 
       If StrComp(x, y) = 1 Then 
        Sheets("BU").Range("C" & k).Copy 
        Sheets("TOPS Information").Range("H" & j).PasteSpecial 
       End If 

       '////////////////////////////////////// 

     Next k 

    Next j 


    End Sub 

Answer 2

只是假設要在BU最頂部找到的數據複製到TOPS，您可以使用以下。

Sub QIM() 
    Dim oWS_TOPS As Worksheet, oWS_BU As Worksheet ' Worksheet objects 
    Dim oRng_TOPS As Range, oRng_BU As Range ' Range objects 
    Dim R_TOPS As Long, R_BU As Long 

    Set oWS_TOPS = ThisWorkbook.Worksheets("TOPS Information") ' <-- Replace this "TOPS Information" to match future changes 
    Set oWS_BU = ThisWorkbook.Worksheets("BU") ' <-- Replace this "BU" to match future changes 

    R_TOPS = oWS_TOPS.Cells(Rows.Count, "A").End(xlUp).Row 
    R_BU = oWS_BU.Cells(Rows.Count, "A").End(xlUp).Row 

    ' Search column B of BU for each cell in column C of TOPS 
    For Each oRng_TOPS In oWS_TOPS.Columns("C").Cells ' <-- Replace this "C" to match future changes 
     ' Exit if row is more than last A column data 
     If oRng_TOPS.Row > R_TOPS Then Exit For 
     For Each oRng_BU In oWS_BU.Columns("B").Cells ' <-- Replace this "B" to match future changes 
      ' Exit if row is more than last A column data 
      If oRng_BU.Row > R_BU Then Exit For 
      ' Check if Ranges match (## See Update ##) 
      If InStr(1, oRng_TOPS.Value, oRng_BU.Value, vbTextCompare) > 0 Then 
       ' Copy column C of found row in BU to column H of TOPS, then exit 
       oWS_BU.Cells(oRng_BU.Row, "C").Copy oWS_TOPS.Cells(oRng_TOPS.Row, "H") ' <-- Replace these "C" and "H" to match future changes 
       Exit For 
      End If 
     Next 
    Next 

    Set oWS_TOPS = Nothing 
    Set oWS_BU = Nothing 
End Sub 

有很多方法可以實現您的目標，這就是其中之一。

---

UPDATE註上比較單元值（字符串）：

StrComp(S1,S2[,mode])只返回3個值{-1，0，1}，以指示如果S1小於/等於/大於S2。如果您想要完全匹配（區分大小寫和確切間距），請使用If StrComp(S1,S2) = 0 Then。

InStr([i,]S1,S2[,mode])只返回正值 - 它返回S1中S2的第一次出現的字符位置。如果沒有找到S2，則返回零。

您還可以使用Trim(sText)刪除sText的前導/結尾空格。

希望低於屏幕截圖說更多。