Hi
I have code that is not writing the expected result and so I could really use some help with making the necessary adjustments. I don’t want to change the code.
Using the Excel image below the expected written result is the grey highlight in the D5:H17 box area. The data gets written based on any set of numbers in the range E6:E17 and comes from the data source cells M5 to O17. So as an example when cell E8 (3rd line down) has the 10-1 in it the code would search the data source (3rd line down) and write from the data source cells M8/N8/O8 to cells F8/G8/H8. I have also uploaded my Excel workbook.
Thanks so much for any help.
Sub PlaceNumbers()
Dim c As Range, rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range
Dim last1 As Long, last2 As Long, rtar As Long, xtar As Long
Application.ScreenUpdating = False
With ActiveSheet
'create arrays
arr1 = Array(.Range("D5:H17"))
arr2 = Array(.Range("L5:O17)) '
'loop through arrays
For i = LBound(arr1) To UBound(arr1)
Set rng1 = arr1(i)
Set rng3 = arr2(i)
last1 = .Cells(.Rows.Count, ColLetter(rng1.Columns(1).Column)).End(xlUp).Row
last2 = .Cells(.Rows.Count, ColLetter(rng3.Columns(1).Column)).End(xlUp).Row
For Each c In rng1.Offset(1, 1).Resize(, 1)
If c <> "" Then
rtar = Evaluate("=MATCH(" & ColLetter(rng1.Columns(2).Column) & rng1.Row & "&" & ColLetter(rng1.Columns(3).Column) & rng1.Row & "," & ColLetter(rng3.Columns(1).Column) & "1:" & ColLetter(rng3.Columns(1).Column) & last2 & "&" & ColLetter(rng3.Columns(3).Column) & "1:" & ColLetter(rng3.Columns(3).Column) & last2 & ",0)")
xtar = Application.Match(c.Offset(0, -2), Range(ColLetter(rng3.Columns(1).Column) & rtar & ":" & ColLetter(rng3.Columns(1).Column) & last2), 0)
With Application.WorksheetFunction
c.Offset(0, 1) = .Index(Range(ColLetter(rng3.Columns(2).Column) & rtar & ":" & ColLetter(rng3.Columns(2).Column) & last2), xtar)
c.Offset(0, 2) = .Index(Range(ColLetter(rng3.Columns(3).Column) & rtar & ":" & ColLetter(rng3.Columns(3).Column) & last2), xtar)
c.Offset(0, 3) = .Index(Range(ColLetter(rng3.Columns(4).Column) & rtar & ":" & ColLetter(rng3.Columns(4).Column) & last2), xtar)
End With
End If
Next c
Next
End With
Application.ScreenUpdating = True
End Sub
Function ColLetter(Collet As Integer) As String
ColLetter = Split(Cells(1, Collet).Address, "$")(1)
End Function
WRITE PROBLEM.png
Bookmarks