Excel VBA条件复制粘贴Do While循环代码失效问题求助

Hey there! Let's break down what's going wrong with your code and get it working as intended. Here are the key issues and fixes:

Key Problems in Your Original Code #

• Uninitialized Variables: counter and myNum start at 0 by default (since they're declared as Integer but never assigned a value). That's why your Do While loop never runs, and writing these values to JobNumbers columns C/D fills them with 0.
• Typo Error: You have COMAPNYB (missing an 'N') in one of your range references—this will throw a "subscript out of range" error when the code tries to access that sheet.
• Incorrect Target Row Logic: The line b = Worksheets("COMPANYA").Range("D" & Rows.Count).End(xlUp).Offset(0, 3).Row is flawed; Offset(0,3) shifts 3 columns right (to column G), which isn't what you need to find the next empty row in column D.
• Misuse of JobNumbers Worksheet: Your code was writing to this sheet instead of reading the required job counts from it to drive the loop.

Corrected Code #

Private Sub CommandButton6_Click()
    Dim counter As Integer
    Dim myNum As Integer
    Dim lastRowB As Long
    Dim nextRowA As Long
    Dim wsA As Worksheet, wsB As Worksheet, wsJobs As Worksheet
    
    ' Set worksheet references to avoid typos and make code cleaner
    Set wsA = ThisWorkbook.Worksheets("COMPANYA")
    Set wsB = ThisWorkbook.Worksheets("COMPANYB")
    Set wsJobs = ThisWorkbook.Worksheets("JobNumbers")
    
    ' Get the job count from JobNumbers (adjust the range to where your count is stored, e.g., C2)
    myNum = wsJobs.Range("C2").Value ' Update this to your actual count cell
    counter = 1 ' Initialize counter to start at 1
    
    ' Write initial counter values to JobNumbers (optional, if you need to track)
    wsJobs.Range("C:C").Value = myNum
    wsJobs.Range("D:D").Value = counter
    
    ' Get last row with data in Company B
    lastRowB = wsB.Range("A" & wsB.Rows.Count).End(xlUp).Row
    
    Do While counter <= myNum
        ' Flag to check if we found a match for this iteration
        Dim matchFound As Boolean
        matchFound = False
        
        For i = 2 To lastRowB
            ' Fix the typo and correct the matching logic
            If wsB.Range("D" & i).Value = "Match" And _
               wsB.Range("E" & i).Value = wsA.Range("C" & counter).Value Then ' Match to current row in Company A
                
                ' Find next empty row in Company A column D
                nextRowA = wsA.Range("D" & wsA.Rows.Count).End(xlUp).Row
                If nextRowA < counter Then nextRowA = counter ' Ensure we align with Company A's row
                
                ' Copy as link to Company A's D-F columns
                wsB.Range("A" & i & ":C" & i).Copy
                wsA.Range("D" & nextRowA).PasteLink Link:=True
                matchFound = True
                Exit For ' Exit loop once we find the match for this counter
            End If
        Next i
        
        ' If no match found, leave the row blank (do nothing, since we're not writing anything)
        counter = counter + 1
        ' Optional: Update JobNumbers with current counter values
        wsJobs.Range("D:D").Value = counter
    Loop
    
    ' Clean up clipboard
    Application.CutCopyMode = False
    MsgBox "Process completed!", vbInformation
End Sub

Key Improvements Explained #

• Worksheet Variables: Using wsA, wsB, wsJobs makes the code cleaner and avoids typo errors with sheet names.
• Proper Variable Initialization: We now read myNum from the JobNumbers sheet (adjust the cell reference to where your actual job count is stored) and start counter at 1.
• Fixed Matching Logic: The code now matches each row in Company A (using counter as the row index) to the corresponding matched entry in Company B.
• Correct Target Row Handling: We ensure the pasted link aligns with the current row in Company A, leaving blanks if no match is found.
• Cleanup: Added Application.CutCopyMode = False to clear the clipboard after the process.

内容的提问来源于stack exchange，提问作者Shaun