Macro to transfer Cells from File1 to File2 where a Y is typed in Col K

R

rehana402003

New Member
Joined
Jun 9, 2016
Messages
10
Hello All,

I am using Excel 2013 and have the following problem.

I have two workbooks which I use for Data entry and for updating the master Data Sheet
Both the workbooks are open at the time of Data Entry.
Data Entry is done on the Active Sheet of File1

eg:

File1.xlsx – From file

File2.xlsx (Cells transferred to Sheetname ‘DATA’) – To File

My objective is to have a macro when I do entries on File1 (Activesheet)
It should look for Y under Column K and do the following

Cell Values typed in File1 should be copied to File2 (in the last row available) as follows:

Col A should be pasted to Col J
Col B should be pasted to Col A
Col C should be pasted to Col B
Col D should be pasted to Col I
Col G should be pasted to Col H

All the Cells where a Y is under Col K should get transferred from File 1 to File 2 as mentioned above.

Thanks in advance
Rehana
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Sort by date Sort by votes
Hello All,
I found this code on the net
Can someone amend it to suit my need please?
Thanks in advance

Sub MoveRowBasedOnCellValue()<o:p></o:p>'Updated by Extendoffice 2017/11/10<o:p></o:p> Dim xRg As Range<o:p></o:p> Dim xCell As Range<o:p></o:p> Dim I As Long<o:p></o:p> Dim J As Long<o:p></o:p> Dim K As Long<o:p></o:p> I = Worksheets("Sheet1").UsedRange.Rows.Count<o:p></o:p> J = Worksheets("Sheet2").UsedRange.Rows.Count<o:p></o:p> If J = 1 Then<o:p></o:p> If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0<o:p></o:p> End If<o:p></o:p> Set xRg = Worksheets("Sheet1").Range("C1:C" & I)<o:p></o:p> On Error Resume Next<o:p></o:p> Application.ScreenUpdating = False<o:p></o:p> For K = 1 To xRg.Count<o:p></o:p> If CStr(xRg(K).Value) = "Done" Then<o:p></o:p> xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)<o:p></o:p> J = J + 1<o:p></o:p> End If<o:p></o:p> Next<o:p></o:p> Application.ScreenUpdating = True<o:p></o:p>End Sub
<o:p></o:p>
 
Upvote 0
sorry forgot to put it the tag
Code: 
[COLOR=#0A0101][FONT=Consolas]Sub MoveRowBasedOnCellValue()<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]'Updated by Extendoffice 2017/11/10<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Dim xRg As Range<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Dim xCell As Range<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Dim I As Long<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Dim J As Long<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Dim K As Long<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    I = Worksheets("Sheet1").UsedRange.Rows.Count<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    J = Worksheets("Sheet2").UsedRange.Rows.Count<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    If J = 1 Then<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    End If<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Set xRg = Worksheets("Sheet1").Range("C1:C" & I)<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    On Error Resume Next<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Application.ScreenUpdating = False<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    For K = 1 To xRg.Count<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]        If CStr(xRg(K).Value) = "Done" Then<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]            J = J + 1<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]        End If<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Next<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Application.ScreenUpdating = True<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]End Sub<o:p></o:p>[/FONT][/COLOR]
 
Upvote 0
Code: 
[COLOR=#0A0101][FONT=Consolas]Sub MoveRowBasedOnCellValue()[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]'Updated by Extendoffice 2017/11/10<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Dim xRg As Range<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Dim xCell As Range<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Dim I As Long<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Dim J As Long<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Dim K As Long<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    I = Worksheets("Sheet1").UsedRange.Rows.Count<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    J = Worksheets("Sheet2").UsedRange.Rows.Count<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    If J = 1 Then<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    End If<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Set xRg = Worksheets("Sheet1").Range("C1:C" & I)<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    On Error Resume Next<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Application.ScreenUpdating = False<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    For K = 1 To xRg.Count<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]        If CStr(xRg(K).Value) = "Done" Then<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]            J = J + 1<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]        End If<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Next<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]    Application.ScreenUpdating = True<o:p></o:p>[/FONT][/COLOR][COLOR=#0A0101][FONT=Consolas]End Sub[/FONT][/COLOR]
 
Upvote 0
Code: 
Sub MoveRowBasedOnCellValue()
'Updated by Extendoffice 2017/11/10
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Done" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Macro to load 10 files from different folder into different sheets in Master File
Replies
2
Views
435
joxyin
J
D
  • Question Question
Retrieve values from workbooks saved in another drive
Replies
8
Views
446
mumps
mumps
M
  • Question Question
Macro code to copy & paste cell data
Replies
1
Views
144
Maverick27
M
D
  • Question Question
macro to compare two excel file.
Replies
4
Views
5K
DanteAmor
DanteAmor
E
  • Question Question
Filtering values from data source and pasting it into a second workbook
2
Replies
17
Views
1K
kevin9999
K

Forum statistics

Threads
1,222,752
Messages
6,168,007
Members
452,160
Latest member
Bekerinik

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top