I'm trying to copy and transpose the headers from my source worksheet into my target sheet to use as mappings.
My code copies the row below the one I want (Row 1).
Sub Create_Mappings()
Dim source_sht As Worksheet
Dim target_sht As Worksheet
Dim src_raw_rng As Range 'Ranges for headings from raw_data
Dim trg_raw_rng As Range
Dim src_map_rng As Range 'Ranges for mapping headings
Dim trg_map_rng As Range
Dim last_row As Long
Dim last_column As Long
Set source_sht = ThisWorkbook.Worksheets(6)
Set target_sht = ThisWorkbook.Worksheets(4)
'Determine last row of data in Mappings sheet and last column in first row of Raw_Data
last_row = target_sht.Cells(target_sht.Rows.Count, "C").End(xlUp).Row
last_column = source_sht.Cells(source_sht.Range("A1"), source_sht.Columns.Count).End(xlToLeft).Column
'Clear mappings
Set src_raw_rng = source_sht.Range(source_sht.Cells(1, 1), source_sht.Cells(1, last_column))
Set trg_raw_rng = target_sht.Range(Range("InpVarStart"), target_sht.Cells(last_row + 1, 3))
trg_raw_rng.Clear
src_raw_rng.Copy
trg_raw_rng.PasteSpecial Transpose:=True
End Sub
Try this. Please note the comments starting with '*
Sub Create_Mappings()
Dim source_sht As Worksheet
Dim target_sht As Worksheet
Dim src_raw_rng As Range 'Ranges for headings from raw_data
Dim trg_raw_rng As Range
Dim src_map_rng As Range 'Ranges for mapping headings
Dim trg_map_rng As Range
Dim last_row As Long
Dim last_column As Long
Set source_sht = Sheet6 ' ThisWorkbook.Worksheets(6)
Set target_sht = Sheet4 ' ThisWorkbook.Worksheets(4)
'Determine last row of data in Mappings sheet and last column in first row of Raw_Data
last_row = target_sht.Cells(target_sht.Rows.Count, "C").End(xlUp).Row
'* changed source_sht.Range("A1") to 1
'* you can use source_sht.Range("A1").Row, but 1 is better since you are hard-coding "A1"
last_column = source_sht.Cells(1, source_sht.Columns.Count).End(xlToLeft).Column
'Clear mappings
Set src_raw_rng = source_sht.Range(source_sht.Cells(1, 1), source_sht.Cells(1, last_column))
Set trg_raw_rng = target_sht.Range(Range("InpVarStart"), target_sht.Cells(last_row + 1, 3))
trg_raw_rng.Clear
src_raw_rng.Copy
'* Use first cell of target range
trg_raw_rng.Cells(1, 1).PasteSpecial Transpose:=True
trg_raw_rng.Select
End Sub
Related
I have a simple loop that should copy ranges form three sheets and stack them on top of each other in another sheet. I define the ranges of each of the three sheets via a cell that counts rows in the Control Sheet.
I do not get an error message, however only the range of the first sheets gets pasted. I troubleshooted already to see if the loop is running until end and indeed it does. I cannot wrap my head around why only the range from the first sheets gets pasted in the final sheet.
Sub Loop()
Dim ws_Sheet As Worksheet, ws As Worksheet
Dim lng_LastRow As Long, lng_LastColumn As Long, lng_LastRowSheet As Long
Dim rng_WorkRange As Range
Dim arrSht, i
Dim counter As Integer
arrSht = Array("a", "b", "c")
Set ws_Sheet = Worksheets("d")
ws_Sheet.Cells.ClearContents
counter = 1
For i = 0 To 2
Set ws = Worksheets(arrSht(i))
lng_LastRow = Worksheets("Control").Range("E" & counter).Value + 1
lng_LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
lng_LastRowSheet = ws_Sheet.Cells(Rows.Count, 1).End(xlUp).Row
Set rng_WorkRange = ws.Range(ws.Cells(1, 1), ws.Cells(lng_LastRow, lng_LastColumn))
rng_WorkRange.Copy ws_Sheet.Range("A" & lng_LastRowSheet)
counter = counter + 1
Next i
End Sub
The issue is
lng_LastRowSheet = ws_Sheet.Cells(Rows.Count, 1).End(xlUp).Row
is the last used row (the last row that has data).
And then you use that to start pasting
rng_WorkRange.Copy ws_Sheet.Range("A" & lng_LastRowSheet)
so you overwrite the last row of data!
The next free row is lng_LastRowSheet + 1 so you should paste there:
rng_WorkRange.Copy ws_Sheet.Range("A" & (lng_LastRowSheet + 1))
You can also see that in the debug data:
a $A$1:$B$338 to A1
b $A$1:$B$91 to A338
c $A$1:$B$356 to A428
a goes from A1:B338 but you start pasting b in A338 so it overwrites the last row of a.
I gave it a test:
Created worksheet Control with data like
Then created worksheets a, b and c like
with data until row 500 so there is enough.
Then created an empty worksheet d for the output.
And used the following code. Note I have optimized it so it uses meaningful variable names, which is much easier to read, understand and debug.
Option Explicit
Public Sub CopyData()
Dim SheetNames() As Variant
SheetNames = Array("a", "b", "c")
Dim wsDestination As Worksheet
Set wsDestination = ThisWorkbook.Worksheets("d")
wsDestination.Cells.ClearContents
Dim i As Long
For i = 0 To 2
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Worksheets(SheetNames(i))
Dim SourceLastRow As Long
SourceLastRow = ThisWorkbook.Worksheets("Control").Range("E" & i + 1).Value + 1
Dim SourceLastColumn As Long
SourceLastColumn = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
Dim DestinationFreeRow As Long
DestinationFreeRow = wsDestination.Cells(wsDestination.Rows.Count, 1).End(xlUp).Row + 1 ' Last used row +1
Dim SourceRange As Range
Set SourceRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(SourceLastRow, SourceLastColumn))
SourceRange.Copy wsDestination.Range("A" & DestinationFreeRow)
Next i
End Sub
And I get a perfect output like:
Note that in the output I have hidden some rows so you can see eveything is there. This code perfectly does what it is supposed to.
Stack Ranges (Vertically) From Multiple Worksheets
Sub StackRanges()
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sWorksheetNames() As Variant: sWorksheetNames = VBA.Array("a", "b", "c")
' Lookup (Source Last Row)?
Dim lws As Worksheet: Set lws = wb.Worksheets("Control")
Dim llrCell As Range: Set llrCell = lws.Range("E1")
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("d")
dws.UsedRange.ClearContents
Dim dfCell As Range: Set dfCell = dws.Range("A1")
Dim sws As Worksheet
Dim srg As Range
Dim slRow As Long
Dim slColumn As Long
Dim i As Long
' Loop.
For i = 0 To UBound(sWorksheetNames)
Set sws = wb.Worksheets(sWorksheetNames(i))
slRow = llrCell.Value + 1
slColumn = sws.Cells(1, sws.Columns.Count).End(xlToLeft).Column
Set srg = sws.Range("A1", sws.Cells(slRow, slColumn))
srg.Copy dfCell
' If you only need to copy values (since you're using '.ClearContents'),
' instead, use the most efficient:
'dfCell.Resize(srg.Rows.Count, srg.Columns.Count).Value = srg.Value
Set llrCell = llrCell.Offset(1) ' next source last row lookup cell
Set dfCell = dfCell.Offset(srg.Rows.Count) ' next first dest. cell
Next i
End Sub
The counter and the lng_lastRow variable is too messy.
I repaleced some code as follow：
Sub newLoop()
Dim ws_Sheet As Worksheet, ws As Worksheet
Dim lng_LastRow As Long, lng_LastColumn As Long, lng_LastRowSheet As Long
Dim rng_WorkRange As Range, rng_lastRange As Range
Dim arrSht, i
Dim counter As Integer
arrSht = Array("a", "b", "c")
Set ws_Sheet = Worksheets("Control")
ws_Sheet.Cells.ClearContents
For i = 0 To 2
Set ws = Worksheets(arrSht(i))
Set rng_lastRange = ws_Sheet.Cells(Rows.Count, 1).End(xlUp)
lng_LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
lng_LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Set rng_WorkRange = ws.Range(ws.Cells(1, 1), ws.Cells(lng_LastRow, lng_LastColumn))
rng_WorkRange.Copy rng_lastRange.Offset(1, 0)
Next i
End Sub
I know the "Last Row" question has already come up several times but even when looking at existing threads I cannot find what is happening. It is the first time I write a Macro so I have only been able to get to a certain point I paste the code and ask the questions later:
Option Explicit
Sub Practice()
'Last Row Searcher
Dim Sht As Worksheet
Set Sht = ActiveSheet
Dim Last_Row As Long
With Sht
Last_Row = .Range("A9999").End(xlUp).Row
End With
'Column A to D
Sheet9.Select
Range("A2:A" & Last_Row).Copy
Sheet11.Select
Range("D" & Last_Row).Select
ActiveSheet.Paste
'Column C to F
Sheet9.Select
Range("C2:C" & Last_Row).Copy
Sheet11.Select
Range("F" & Last_Row + 1).Select
ActiveSheet.Paste
'Column E to G
Sheet9.Select
Range("E2:E" & Last_Row).Copy
Sheet11.Select
Range("G" & Last_Row + 1).Select
ActiveSheet.Paste
'Column I to L
Sheet9.Select
Range("I2:I" & Last_Row).Copy
Sheet11.Select
Range("L" & Last_Row + 1).Select
ActiveSheet.Paste
End Sub
Question 1:
When I paste what I have copied to the other worksheet it directly pastes things in the "Last_Row" from the previous worksheet instead of looking for the new "Last_Row" of the Active Sheet. Is there a way around this?
Question 2
I repeat the same code several times but with different columns, because they are not together I copy column A to D, then C to F, etc.
It is working for me, but out of curiosity, is there a way to do it all at once?
(First Empty Row After) Last Non-Empty Row
Option Explicit
Sub Practice()
'Last Row Searcher
Const frSrc As Long = 2 ' Source First Row
Const strSrc As String = "A,C, E, I" ' Source Column Letters
Const strTgt As String = "D, F,G, L" ' Target Column Letters
Dim wsSrc As Worksheet ' Source Worksheet
Dim wsTgt As Worksheet ' Target Worksheet
Dim rngSrc As Range ' Source Column Range
Dim rngTgt As Range ' Target Column Range
Dim vntS As Variant ' Source Column Array
Dim vntT As Variant ' Target Column Array
Dim lrSrc As Long ' Source Last Non-Empty Row
Dim frTgt As Long ' Target First Row After Last Non-Empty Row
Dim i As Long ' Source and Target Array Elements Counter
Dim colSrc As String ' Source Column Letter
Dim colTgt As String ' Target Column Letter
' Beware, you are using CodeNames, which are not the names on the TAB.
Set wsSrc = Sheet9
Set wsTgt = Sheet11
' Populate Column Arrays (vntS, vntT).
vntS = Split(strSrc, ","): vntT = Split(strTgt, ",")
' Loop through elements of Source (or Target) Column Array.
For i = 0 To UBound(vntS)
' Calculate Column Letter (colSrc, colTgt)
colSrc = Trim(vntS(i)): colTgt = Trim(vntT(i))
' Calculate Source Last Non-Empty Row.
lrSrc = wsSrc.Range(colSrc & wsSrc.Rows.Count).End(xlUp).Row
' Calculate Target First Row After Last Non-Empty Row.
frTgt = wsTgt.Range(colTgt & wsTgt.Rows.Count).End(xlUp).Row + 1
' Calculate Source Column Range.
Set rngSrc = wsSrc.Range(colSrc & frSrc & ":" & colSrc & lrSrc)
' Calculate Target Column Range.
Set rngTgt = wsTgt.Range(colTgt & frTgt).Resize(rngSrc.Rows.Count)
' Write values of Source Column Range to Target Column Range.
rngTgt.Value = rngSrc.Value
Next
End Sub
EDIT:
Sub Practice2()
'Last Row Searcher
Const frSrc As Long = 2 ' Source First Row
Const strSrc As String = "A,C, E, I" ' Source Column Letters
Const strTgT As String = "D, F,G, L" ' Target Column Letters
Dim wsSrc As Worksheet ' Source Worksheet
Dim wsTgt As Worksheet ' Target Worksheet
Dim rngSrc As Range ' Source Column Range
Dim rngTgt As Range ' Target Column Range
Dim vntS As Variant ' Source Column Array
Dim vntT As Variant ' Target Column Array
Dim lrSrc As Long ' Source Last Non-Empty Row
Dim frTgt As Long ' Target First Row After Last Non-Empty Row
Dim i As Long ' Source and Target Array Elements Counter
Dim colSrc As String ' Source Column Letter
Dim colTgt As String ' Target Column Letter
' Beware, you are using CodeNames, which are not the names on the TAB.
Set wsSrc = Sheet9
Set wsTgt = Sheet11
' Populate Column Arrays (vntS, vntT).
vntS = Split(strSrc, ",")
vntT = Split(strTgT, ",")
' Calculate Target First Row After Last Non-Empty Row.
frTgt = wsTgt.Range(Trim(vntT(0)) & wsTgt.Rows.Count).End(xlUp).Row + 1
' Loop through elements of Source (or Target) Column Array.
For i = 0 To UBound(vntS)
' Calculate Column Letter (colSrc, colTgt)
colSrc = Trim(vntS(i)): colTgt = Trim(vntT(i))
' Calculate Source Last Non-Empty Row.
lrSrc = wsSrc.Range(colSrc & wsSrc.Rows.Count).End(xlUp).Row
' Calculate Source Column Range.
Set rngSrc = wsSrc.Range(colSrc & frSrc & ":" & colSrc & lrSrc)
' Calculate Target Column Range.
Set rngTgt = wsTgt.Range(colTgt & frTgt).Resize(rngSrc.Rows.Count)
' Write values of Source Column Range to Target Column Range.
rngTgt.Value = rngSrc.Value
Next
End Sub
You need to set define the "last row" more clearly. In your case, I believe what you want is to find the last row of the source data AND then paste it after the last row of your destination sheet. So try something like this:
Dim srcWS As Worksheet
Set srcWS = Sheet9
Dim dstWS As Worksheet
Set dstWS = Sheet11
Dim srcLastRow As Long
With srcWS
srcLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Dim dstLastRow As Long
With dstWS
dstLastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
End With
srcWS.Range("A2:A" & srcLastRow).Copy
dstWS.Range("D" & dstLastRow).Paste
No Select or ActiveSheet is necessary (which you should avoid whenever you can).
Adding another answer here because my previous answer was incomplete (and it's been bothering me since yesterday!). Since this is a repetitive bit of code, I would separate the column-copy into it's own sub. Your logic becomes very simple in your main routine.
Option Explicit
Sub test()
CopyMyColumn Sheet1.Range("A1").EntireColumn, Sheet1.Range("D1").EntireColumn
CopyMyColumn Sheet1.Range("C1").EntireColumn, Sheet1.Range("F1").EntireColumn
CopyMyColumn Sheet1.Range("E1").EntireColumn, Sheet1.Range("G1").EntireColumn
CopyMyColumn Sheet1.Range("I1").EntireColumn, Sheet1.Range("L1").EntireColumn
End Sub
Private Sub CopyMyColumn(ByRef srcColumn As Range, ByRef dstColumn As Range)
'--- copies the source column from row 2 to the end of the data, to
' the destination column, appending to the end of the existing data
Dim srcLastRow As Long
With srcColumn
srcLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Dim dstLastRow As Long
With dstColumn
dstLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Dim src As Range
Dim dst As Range
Set src = srcColumn.Cells(2, 1).Resize(srcLastRow, 1)
Set dst = dstColumn.Cells(1, 1).Offset(dstLastRow, 0).Resize(srcLastRow, 1)
dst.Value = src.Value
End Sub
Would you know what is the following code adjustment needed. Range I have set up (A1:B20) changes over time. The first block of data stays be between A1:B20 and the second block of data always will be between A25:B60. Ranges will change over time. First block of data could reach 200 rows going down. After my code reaches the second block of data and my range falls between that block of data it picks up the range only if I have adjusted manually the range. Please note, Second block of data normally provides duplicates from the first block.
How could I have my code automatically select the first block of data past my range output without having to adjust the "range" manually?
Sub CopyPaste()
Dim lastRow As Long
Dim Sheet2 As Worksheet
Dim Results As Worksheet
Dim LookupLastrow As Long
'code line will set values from sheet
("Sheet1") into ("Sheet2") starting 5 rows down.
Set Results = Sheets("Sheet2")
lastRow = ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, 1).End (xlUp).row
Range("A1:B20" & lastRowcount).Copy
Results.Range("A" & lastRow + 5).PasteSpecial xlPasteValuesAndNumberFormats
Application.GoTo ActiveSheet.Range("A1"), True
Application.CutCopyMode = False
End Sub
Think simple. No need to build strings for range addresses, and no need for using the clipboard with .Copy and .Paste. Use a direct assignment to the .Value property in a table of cells.
Public Sub CopyValues()
Dim r_src As Range, r_dst As Range
' Source starts at row 20
Set r_src = Sheets("Sheet 2").Cells(20, 1)
' Destination starts at row 5
Set r_dst = Sheets("Sheet 1").Cells(5, 1)
Dim n As Long
' Count the non-empty cells
n = r_src.Range(r_src, r_src.End(xlDown)).Rows.Count
' Copy n rows and 2 columns with one command
r_dst.Resize(n, 2).Value = r_src.Resize(n, 2).Value
End Sub
Based on the picture you showed, the following code will capture the entire top and bottom sections, regardless of how many lines or columns exists. This assumes your top section will start in "A8" as shown. You can edit the code to reflect your actual sheet names.
Sub CopyPaste()
Dim OrigLastRow As Long
Dim OrigLastCol As Long
Dim DestLastRow As Long
Dim OrigRng As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Origin")
Set ws2 = ThisWorkbook.Worksheets("Destination")
OrigLastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
OrigLastCol = ws1.Cells(10, Columns.Count).End(xlToLeft).Column
DestLastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 5
Set OrigRng = ws1.Range(ws1.Cells(8, 1), ws1.Cells(OrigLastRow, OrigLastCol))
OrigRng.Copy
ws2.Cells(DestLastRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End Sub
The version below creates a top and bottom section like your picture and copies both sections separately with a 5 row gap in the destination.
Sub CopyPaste2()
Dim OrigLastRow As Long
Dim OrigLastCol As Long
Dim TopLastRow As Long
Dim BotLastRow As Long
Dim DestLastRow As Long
Dim OrigTopRng As Range
Dim OrigBotRng As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Origin")
Set ws2 = ThisWorkbook.Worksheets("Destination")
'Assumes contiguous data from row 8 down
TopLastRow = ws1.Cells(8, 1).End(xlDown).Row
BotLastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
OrigLastCol = ws1.Cells(10, Columns.Count).End(xlToLeft).Column
DestLastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 5
'Assumes we are starting the top range in row 8
Set OrigTopRng = ws1.Range(ws1.Cells(8, 1), ws1.Cells(TopLastRow, OrigLastCol))
'Columns I & J as shown in the picture
Set OrigBotRng = ws1.Range(ws1.Cells(TopLastRow + 5, 9), ws1.Cells(BotLastRow, 10))
OrigTopRng.Copy
ws2.Cells(DestLastRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
'Recalculate destination last row
DestLastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 5
OrigBotRng.Copy
ws2.Cells(DestLastRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End Sub
I want to copy a range of cells, say F10:F59, of the Form sheet, then transpose and paste them to another range on another sheet named Stock Manual Senin, say B11:BA25.
This is what I currently have:
Sub InputPAGS_Senin()
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim vntRange As Variant
Dim lastRow As Long
Set copySheet = Sheets("Form")
Set pasteSheet = Sheets("Stock Manual Senin")
' Calculate last row of data.
lastRow = pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
' Copy 2 cells.
pasteSheet.Cells(lastRow + 1, 1).Offset(0, 1) = copySheet.Range("N2").Value
' Paste column range into array.
vntRange = copySheet.Range("F10:F59").Value
' Paste transpose array into row range.
Sheets("Stock Manual Senin").Select
Range("B11:BA25").Select
pasteSheet.Cells(lastRow + 1, 1).Offset(0, 3).Resize(, copySheet _
.Range("F10:F59").Rows.Count).Value = Application.Transpose(vntRange)
End Sub
the paste target should be in row 11, but it'd paste in row 285 cause target range is located between the others table's row.
Can anyone advise me on how I should continue please? Thank you.
xlUp Becomes xlDown
You have to calculate the last row from NAMA TOKO down (xlDown). Do not delete NAMA TOKO and PAGS / MIGO, then you can use the following
lastRow = pasteSheet.Cells(9, 2).End(xlDown).Offset(1).Row
or even better
lastRow = pasteSheet.Cells(9, 2).End(xlDown).Row + 1
Does something like this work? I just did a manual pivot as I wrote out the values.
Sub SOTest()
Dim copySheet As Worksheet
Dim CopyRange As Range
Dim Cell As Range
Dim pasteSheet As Worksheet
Dim lastRow As Long
Dim ColIndex As Long
Set copySheet = ThisWorkbook.Worksheets("Form")
Set pasteSheet = ThisWorkbook.Worksheets("Stock Manual Senin")
Set CopyRange = copySheet.Range("F10:F59")
ColIndex = 2 'Column B
With pasteSheet
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
End With
Application.ScreenUpdating = False
For Each Cell In CopyRange
pasteSheet.Cells(lastRow, ColIndex).Value = Cell.Value
ColIndex = ColIndex + 1
Next
Application.ScreenUpdating = True
End Sub
I have 2 worksheets. sheet1 is monthly Value on col A. Sheet 2 is daily value on col A, I would Like Excel to look for the same value in worksheet 2 (Daily), then once it finds that exact value, to copy the matched rows form sheet 1 (monthly) and paste it in sheet 2 (Daily).
Any ideas how to write a VBA code that will automate this copy and paste values process? (see the screenshot)
[1]: https://i.stack.imgur.com/G5LqW.png
[on the right handside, data is per month (last day of each month), i need to match col Aof both sheets, and bring the data to other sheet on exact day (last day of that month)][1]
Untested
Sub Copy18()
Dim wb As Workbook
Dim wsD2 As worksheet, wsM2 As Worksheets
Dim LastRow As long, LastCol As Long, i as long
Dim Cell As Range, Rng As Range, SearchR As Range, CopyRng As Range, PasteRng As Range
Set wb = ThisWorkbook
Set wsD2 = wb.Sheets("Daily-2")
Set wsM2 = wb.Sheets("Monhly-2")
LastCol = wsM2.Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = wsM2.Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = wsD2.Range(wsD2.Cells(1,1), wsD2.Cells(LastRow, LastCol))
For Each Cell in Rng
Set SearchR = wsM2.Range("A:A").Find(Cell.Value, LookAt:=xlWhole)
If Not SearchR Is Nothing Then
i = LastCol = wsM2.Cells(SearchR.Row, Columns.Count).End(xlToLeft).Column
Set CopyRng = wsM2.Range(wsM2.Cells(SearchR.Row, 1), wsM2.Cells(SearchR.Row, i))
Set PasteRng = wsD2.Range(wsD2.Cells(LastRow + 1, 1), wsD2.Cells(LastRow + 1, i))
PasteRng.Value = CopyRng.Value
LastRow = LastRow + 1
End If
Next Cell
End Sub