excel - The program works wrong and gives wrong output. The program take article number from input.xlsm file and copy corespondi

admin管理员组

文章数量:1391987

We need help with the program. The program works wrong and gives wrong output. The program take article number from input.xlsm file and copy coresponding value school to the result.xlsm file where insertdata() program located. Sometimes the program mistaken with output. wrong output appear in school colomn.The file input and result are very large and the output mistake with wrong school column record.

Sub Insertdata()
    Dim src As Workbook
    Dim fnd As Range
    Dim d As Integer
    Dim lastrow As Integer
    Dim Rng As Range

    Set src = Workbooks.Open("C:\FILE\PRICES\Baltoptt\m\inputintoresult\input.xlsm", True, True)
'    Set src = Workbooks("input.xlsm")
    Set Rng = src.Sheets("sheet1").Range("A:A")
    d = 1
    
    With ThisWorkbook.Sheets("sheet1")
        lastrow = .UsedRange.Rows.Count
        Do Until d = lastrow
            Set fnd = Rng.Find(.Cells(d, 1))
            If Not fnd Is Nothing Then .Cells(d, 6) = fnd.Offset(, 5)
            d = d + 1
        Loop
    End With
End Sub

We need help with the program. The program works wrong and gives wrong output. The program take article number from input.xlsm file and copy coresponding value school to the result.xlsm file where insertdata() program located. Sometimes the program mistaken with output. wrong output appear in school colomn.The file input and result are very large and the output mistake with wrong school column record.

Sub Insertdata()
    Dim src As Workbook
    Dim fnd As Range
    Dim d As Integer
    Dim lastrow As Integer
    Dim Rng As Range

    Set src = Workbooks.Open("C:\FILE\PRICES\Baltoptt\m\inputintoresult\input.xlsm", True, True)
'    Set src = Workbooks("input.xlsm")
    Set Rng = src.Sheets("sheet1").Range("A:A")
    d = 1
    
    With ThisWorkbook.Sheets("sheet1")
        lastrow = .UsedRange.Rows.Count
        Do Until d = lastrow
            Set fnd = Rng.Find(.Cells(d, 1))
            If Not fnd Is Nothing Then .Cells(d, 6) = fnd.Offset(, 5)
            d = d + 1
        Loop
    End With
End Sub

• excel
• vba

Share Improve this question Follow edited Mar 13 at 13:44 dan rather asked Mar 13 at 13:23 dan ratherdan rather 2922 bronze badges 7

• Please take the time to explain what the correct output would look like and how, exactly, the current code fails to achieve the desired result. The steps you have taken to try to debug the code would also be useful – cybernetic.nomad Commented Mar 13 at 13:28
• wrong output appear in school colomn – dan rather Commented Mar 13 at 13:35
• Make the find more specific Set fnd = Rng.Find(.Cells(d, 1), LookIn:=xlValues, lookat:=xlWhole) Also probably should be greater than ie Do Until d > lastrow – CDP1802 Commented Mar 13 at 13:49
• Where do we insert this code? – dan rather Commented Mar 13 at 14:00
• 1 Replace Set fnd = Rng.Find(.Cells(d, 1)) in your code with Set fnd = Rng.Find(.Cells(d, 1), LookIn:=xlValues, lookat:=xlWhole) – CDP1802 Commented Mar 13 at 14:10

 |  Show 2 more comments

2 Answers 2

Sorted by: Reset to default 0

Here's an alternate approach using Match, which will be a little faster if you have a lot of data:

Sub Insertdata()
    Dim src As Workbook, srcWs As Worksheet, ws As Worksheet
    Dim i As Long, m As Variant, v As Variant
    
    Set src = Workbooks.Open("C:\FILE\PRICES\Baltoptt\m\inputintoresult\input.xlsm", True, True)
    Set srcWs = src.Worksheets("sheet1")  'sheet with lookup table
    
    Set ws = ThisWorkbook.Worksheets("sheet1")
    For i = 1 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        v = ws.Cells(i, 1).Value          'article
        m = Application.Match(v, srcWs.Columns("A"), 0)   'try to match the value in Col A
        If Not IsError(m) Then            'got a match?
            ws.Cells(m, 6).Value = srcWs.Cells(m, 6).Value
        Else
            'optionally clear any existing school value...
            Debug.Print "No match for " & v & " on row " & i
        End If
    Next i
End Sub

A VBA Lookup

Sub UpdateSchools()
    
    ' Define constants.
    Const SRC_FILE_PATH As String = _
        "C:\FILE\PRICES\Baltoptt\m\inputintoresult\input.xlsm"
    Const SRC_SHEET_NAME As String = "Sheet1"
    Const SRC_LOOKUP_COLUMN As String = "A" ' 2.) ... here,...
    Const SRC_RETURN_COLUMN As String = "F" ' 3.) ... and return this... 
    Const SRC_FIRST_ROW As Long = 2
    Const DST_SHEET_NAME As String = "Sheet1"
    Const DST_LOOKUP_COLUMN As String = "A" ' 1.) Look for this...
    Const DST_RETURN_COLUMN As String = "F" ' 4.) ... here.
    Const DST_FIRST_ROW As Long = 2
    Const NOT_AVAILABLE As String = "Nope"
    
    ' Source
    Dim swb As Workbook: Set swb = Workbooks.Open(SRC_FILE_PATH, True, True)
    Dim sws As Worksheet: Set sws = swb.Sheets(SRC_SHEET_NAME)
    Dim slrg As Range, srrg As Range, sRowsCount As Long
    With sws.Cells(SRC_FIRST_ROW, SRC_LOOKUP_COLUMN)
        sRowsCount = sws.Cells(sws.Rows.Count, .Column).End(xlUp).Row - .Row + 1
        If sRowsCount < 1 Then Exit Sub ' no data
        Set slrg = .Resize(sRowsCount) ' lookup
        Set srrg = slrg.EntireRow.Columns(SRC_RETURN_COLUMN) ' return
    End With
    
    ' Destination
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.Sheets(DST_SHEET_NAME)
    Dim dlrg As Range, drrg As Range, dRowsCount As Long
    With dws.Cells(DST_FIRST_ROW, DST_LOOKUP_COLUMN)
        dRowsCount = dws.Cells(dws.Rows.Count, .Column).End(xlUp).Row - .Row + 1
        If dRowsCount < 1 Then Exit Sub ' no data
        Set dlrg = .Resize(dRowsCount) ' lookup
        Set drrg = dlrg.EntireRow.Columns(DST_RETURN_COLUMN) ' return
    End With
    
    ' Return the matching row indices in an array.
    Dim drData As Variant:
    With Application
        drData = .IfError(.Match(dlrg, slrg, 0), NOT_AVAILABLE)
    End With

    ' Replace the matching row indices with the corresponding return values
    ' and populate the destination range.     
    If IsArray(drData) Then ' multiple rows
        Dim srData() As Variant, sRow As Variant, dRow As Long
        If sRowsCount = 1 Then
            ReDim srData(1 To 1, 1 To 1): srData(1, 1) = srrg.Value
        Else
            srData = srrg.Value
        End If
        For dRow = 1 To dRowsCount
            sRow = drData(dRow, 1)
            If IsNumeric(sRow) Then drData(dRow, 1) = srData(sRow, 1)
        Next dRow
        drrg.Value = drData
    Else ' single row
        If IsNumeric(drData) Then 
            drrg.Value = srrg.Value
        Else
            drrg.Value = NOT_AVAILABLE
        End If
    End If
    
    'swb.Close SaveChanges:=False
    
    MsgBox "Schools updated.", vbInformation
    
End Sub

本文标签：