I want to use the newcttnbr row to intersect with the By.Cells(2, i) column.

Also newcttnbr is a single cell...

Sub NvxDetail()

Dim Ax As Worksheet: Set Ax = Workbooks("MODÈLE DE PROPOSITION DE CONTRAT DE SOUS-TRAITANCE.").Worksheets("Proposition de contrat")
Dim By As Worksheet: Set By = Workbooks("Suivi contrat fact").Worksheets("Détail")
Dim last_row As Integer: last_row = Ax.Cells(Ax.Rows.Count, 3).End(xlUp).Row
Dim arng As Range: Set arng = Ax.Range(Ax.Cells(13, 1), Ax.Cells(last_row, 1))
Dim ByLastRow As Long: ByLastRow = By.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
Dim newcttnbr As Range: Set newcttnbr = By.Cells(ByLastRow, 1)

    Ax.Range("C12").Copy
    newcttnbr.PasteSpecial xlPasteValues
       Application.CutCopyMode = False
       ActiveCell.Select


For i = 4 To 104
    For Each c In arng
        If By.Cells(2, i).Value = c.Value Then
           Intersect(newcttnbr(1, i), By.Cells(2, i)).Value = c.Offset(0, 5).Value
           Exit For
        End If
    Next
Next


End Sub

CodePudding user response：

VBA Lookup

• This is a slightly different approach using Application.Match instead of the inner loop.
• Use Option Explicit at the beginning of each module. It forces you to declare all variables; in your code e.g. Dim i As Long and Dim c As Range are missing.
• If you put the values in constants at the beginning of the code, it's much easier to tweak them. The code becomes more complicated though.
• In a nutshell, it looks in row 2 of the destination to find a match in column A of the source to copy the value from the matching row in column F (of the source) to the matching column in the first available row of the destination.

Option Explicit

Sub PopulateNvxDetail()

    ' Define constants.
    
    ' Source
    Const swbName As String _
        = "MODELE DE PROPOSITION DE CONTRAT DE SOUS-TRAITANCE."
    Const swsName As String = "Proposition de contrat"
    Const sfRow As Long = 13 ' first data row
    Const stCol As String = "C" ' title
    Const slCol As String = "A" ' lookup
    Const svCol As String = "F" ' value
    ' Destination
    Const dwbName As String = "Suivi contrat fact"
    Const dwsName As String = "Détail"
    Const dtCol As String = "A" ' title
    Const dlrgAddress As String = "D2:CV2" ' lookup (value depends on first r.)
 
    ' Source
 
    Dim swb As Workbook: Set swb = Workbooks(swbName)
    Dim sws As Worksheet: Set sws = swb.Worksheets(swsName)
    Dim slRow As Long ' in the title column
    slRow = sws.Cells(sws.Rows.Count, stCol).End(xlUp).Row
    Dim stCell As Range: Set stCell = sws.Cells(sfRow - 1, stCol)
    Dim slrg As Range ' lookup range (compare), it's a column
    Set slrg = sws.Range(sws.Cells(sfRow, slCol), sws.Cells(slRow, slCol))
    Dim svrg As Range ' value range (copy) ' it's a column
    Set svrg = slrg.EntireRow.Columns(svCol)
    
    ' Destination
    
    Dim dwb As Workbook: Set dwb = Workbooks(dwbName)
    Dim dws As Worksheet: Set dws = dwb.Worksheets(dwsName)
    Dim dFirstRow As Long ' in the title column
    dFirstRow = dws.Cells(dws.Rows.Count, dtCol).End(xlUp).Offset(1).Row
    Dim dtCell As Range: Set dtCell = dws.Cells(dFirstRow, dtCol)
    Dim dlrg As Range ' lookup range (compare), it's a row
    Set dlrg = dws.Range(dlrgAddress)
    Dim dvrg As Range ' value range (write), it's a row
    Set dvrg = dlrg.EntireColumn.Rows(dFirstRow)

    ' Write the title?
    dtCell.Value = stCell.Value ' title?
    
    ' Lookup.
    
    Dim srIndex As Variant ' row
    Dim dCell As Range
    Dim dcIndex As Long ' column
    
    For Each dCell In dlrg.Cells ' lookup
        dcIndex = dcIndex   1
        ' This replaces the inner loop!
        srIndex = Application.Match(dCell.Value, slrg, 0) ' lookup
        If IsNumeric(srIndex) Then ' match found
            dvrg.Cells(dcIndex).Value = svrg.Cells(srIndex).Value ' value
        'Else ' match not found; do nothing
        End If
    Next dCell

    MsgBox "Data copied.", vbInformation

End Sub

CodePudding user response：

Probably it didn't intersect! Try the following:

Dim IntSect As Range
Set IntSect = Nothing
Set IntSect = Intersect(newcttnbr(1, i), By.Cells(2, i))
If IntSect Is Nothing Then
    MsgBox "No intersection"
Else
    IntSect.Value = c.Offset(0, 5).Value
End If

CodePudding user response：

Full code corrected using EntireRow and EntireColumn to find the intersect:

Sub NvxDetail()

Dim Ax As Worksheet: Set Ax = Workbooks("MODÈLE DE PROPOSITION DE CONTRAT DE SOUS-TRAITANCE.").Worksheets("Proposition de contrat")
Dim By As Worksheet: Set By = Workbooks("Suivi contrat fact").Worksheets("Détail")
Dim last_row As Integer: last_row = Ax.Cells(Ax.Rows.Count, 3).End(xlUp).Row
Dim arng As Range: Set arng = Ax.Range(Ax.Cells(13, 1), Ax.Cells(last_row, 1))
Dim ByLastRow As Long: ByLastRow = By.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
Dim newcttnbr As Range: Set newcttnbr = By.Cells(ByLastRow, 1)

    Ax.Range("C12").Copy
    newcttnbr.PasteSpecial xlPasteValues
       Application.CutCopyMode = False
       ActiveCell.Select


For i = 4 To 104
    For Each c In arng
        If By.Cells(2, i).Value = c.Value Then
           By.Cells(ByLastRow, i).Value = c.Offset(0, 6).Value
           Exit For
        End If
    Next
Next


End Sub