Need Help for pasting data for 2 columns instead of 1 column

[JOEYSCLEE]

Hi, there
Would you please help to modify the following code? :help

In the attachment, there is the data in 2 columns on worksheet "sheet1" and I want to paste those data to the columns (highlighted with orange color)on worksheet "17 CWA".

Actually, I found the following code in the web site but It only loops through 1 column instead of 2 columns. Enclose the following link & code for your reviewing.


https://www.extendoffice.com/documents/excel/2617-excel-paste-to-visible-filtered-cells.html



For Each rng1 In InputRng
rng1.Copy
For Each rng2 In OutRng
If rng2.EntireRow.RowHeight > 0 Then
rng2.PasteSpecial
Set OutRng = rng2.Offset(1).Resize(OutRng.Rows.Count)
Exit For
End If
Next
Next

[p45cal]

add the red:
For Each rng1 In InputRng.Rows
For Each rng2 In OutRng.Rows

[Paul_Hossler]

Maybe this




Option Explicit
Sub Test()
Dim rDest As Range, rSrc As Range, rToBeFilled As Range, rBlank As Range
Dim iSrc As Long

Set rDest = Worksheets("17 CWA").Cells(4, 1).CurrentRegion
Set rSrc = Worksheets("Sheet1").Cells(1, 1).CurrentRegion

On Error Resume Next
Set rToBeFilled = rDest.Columns(9).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0

If rToBeFilled Is Nothing Then Exit Sub

Application.ScreenUpdating = False

iSrc = 1

For Each rBlank In rToBeFilled.Cells
rBlank.Value = rSrc.Cells(iSrc, 1).Value
rBlank.Offset(0, 1).Value = rSrc.Cells(iSrc, 2).Value
iSrc = iSrc + 1
Next
Application.ScreenUpdating = True
End Sub

[JOEYSCLEE]

Thanks for your advice!! It works great!!:clap::clap::hi:

[JOEYSCLEE]

Hello, Paul
Thanks for your reply!! Just tested your code but the data of last row did not paste on "17 CWA". Anyway, p45cal already advised my issue. Again, thank you for checking out!!


Maybe this




Option Explicit
Sub Test()
Dim rDest As Range, rSrc As Range, rToBeFilled As Range, rBlank As Range
Dim iSrc As Long

Set rDest = Worksheets("17 CWA").Cells(4, 1).CurrentRegion
Set rSrc = Worksheets("Sheet1").Cells(1, 1).CurrentRegion

On Error Resume Next
Set rToBeFilled = rDest.Columns(9).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0

If rToBeFilled Is Nothing Then Exit Sub

Application.ScreenUpdating = False

iSrc = 1

For Each rBlank In rToBeFilled.Cells
rBlank.Value = rSrc.Cells(iSrc, 1).Value
rBlank.Offset(0, 1).Value = rSrc.Cells(iSrc, 2).Value
iSrc = iSrc + 1
Next
Application.ScreenUpdating = True
End Sub