Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to move data
I need to move the data contained in Sheet1,W:BB, in rows that Sheet1, Column
D match Sheet"Answers" A3 and that Column BA (sheet1) contains 1. Can someone help with a method for performing this miracle? Thanks, M.A.Tyler |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to move data
Failed to mention where I would like to put the information being moved. To
Sheet"answers" starting in cell B4. Thanks again. "M.A.Tyler" wrote: I need to move the data contained in Sheet1,W:BB, in rows that Sheet1, Column D match Sheet"Answers" A3 and that Column BA (sheet1) contains 1. Can someone help with a method for performing this miracle? Thanks, M.A.Tyler |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to move data
Hi M,
I have assumed: that you want to copy data for all rows in columns W:BB whe - Column D value = "Answers" and - Column BA value = 1 I have further assumed that once copied, the original data is to be deleted. Assuming that this accords with your requirements, in a standard module (see below), paste the following code: '========== Option Explicit Public Sub Tester() Dim WB As Workbook Dim SH As Worksheet Dim Rng As Range Dim copyRng As Range Dim destRng As Range Dim iRow As Long Dim i As Long Dim CalcMode As Long Const sStr As String = "Answers" Const dVal As Double = 1 Set WB = Workbooks("myBook.xls") '<<==== CHANGE Set SH = WB.Sheets("Sheet1") '<<==== CHANGE Set destRng = WB.Sheets("Answers").Range("B4") With SH iRow = LastRow(SH, .Columns("A:A")) Set Rng = .Range("W1:BB" & iRow) End With On Error GoTo XIT With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With With SH For i = 1 To iRow If LCase(.Cells(i, "D").Value) = LCase(sStr) _ And .Cells(i, "BA").Value = dVal Then If copyRng Is Nothing Then Set copyRng = .Range(.Cells(i, "W"), _ .Cells(i, "BB")) Else Set copyRng = _ Union(.Range(.Cells(i, "W"), _ .Cells(i, "BB")), copyRng) End If End If Next i End With If Not copyRng Is Nothing Then copyRng.Copy Destination:=destRng copyRng.ClearContents Else 'nothing found, do nothing End If XIT: With Application .Calculation = CalcMode .ScreenUpdating = True End With End Sub '--------------- Function LastRow(SH As Worksheet, _ Optional Rng As Range) If Rng Is Nothing Then Set Rng = SH.Cells End If On Error Resume Next LastRow = Rng.Find(What:="*", _ After:=Rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function '<<========== Alt-F11 to open the VBA Editor Menu | Insert | Module | Paste the above code Alt-F11 to return to Excell Alt-F8 to open the Macros window Select "|Tester" | Run --- Regards. Norman "M.A.Tyler" <Great Lakes State wrote in message ... Failed to mention where I would like to put the information being moved. To Sheet"answers" starting in cell B4. Thanks again. "M.A.Tyler" wrote: I need to move the data contained in Sheet1,W:BB, in rows that Sheet1, Column D match Sheet"Answers" A3 and that Column BA (sheet1) contains 1. Can someone help with a method for performing this miracle? Thanks, M.A.Tyler |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to move data
Hi Norman,
First let me thank you for your efforts, I certainly appreciate the help. I think we're close to the solution, just a couple tweeks. First there are two worksheets Sheet1 and "Answers". It's the first "assumtion" that is the problem. Column D value (in sheet1) must = value in sheet "Answers" cell A3 in addition too (second part) Sheet1 Column BA value = 1. Then you are correct, copy data for all rows in columns W:BB, where both criteria are met. Also I would prefer, that once copied, the original data be kept, as it is used from that location in subsequent calculations. I apologise for keeping you guessing, again thanks for the help! Regards, Mike. "Norman Jones" wrote: Hi M, I have assumed: that you want to copy data for all rows in columns W:BB whe - Column D value = "Answers" and - Column BA value = 1 I have further assumed that once copied, the original data is to be deleted. Assuming that this accords with your requirements, in a standard module (see below), paste the following code: '========== Option Explicit Public Sub Tester() Dim WB As Workbook Dim SH As Worksheet Dim Rng As Range Dim copyRng As Range Dim destRng As Range Dim iRow As Long Dim i As Long Dim CalcMode As Long Const sStr As String = "Answers" Const dVal As Double = 1 Set WB = Workbooks("myBook.xls") '<<==== CHANGE Set SH = WB.Sheets("Sheet1") '<<==== CHANGE Set destRng = WB.Sheets("Answers").Range("B4") With SH iRow = LastRow(SH, .Columns("A:A")) Set Rng = .Range("W1:BB" & iRow) End With On Error GoTo XIT With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With With SH For i = 1 To iRow If LCase(.Cells(i, "D").Value) = LCase(sStr) _ And .Cells(i, "BA").Value = dVal Then If copyRng Is Nothing Then Set copyRng = .Range(.Cells(i, "W"), _ .Cells(i, "BB")) Else Set copyRng = _ Union(.Range(.Cells(i, "W"), _ .Cells(i, "BB")), copyRng) End If End If Next i End With If Not copyRng Is Nothing Then copyRng.Copy Destination:=destRng copyRng.ClearContents Else 'nothing found, do nothing End If XIT: With Application .Calculation = CalcMode .ScreenUpdating = True End With End Sub '--------------- Function LastRow(SH As Worksheet, _ Optional Rng As Range) If Rng Is Nothing Then Set Rng = SH.Cells End If On Error Resume Next LastRow = Rng.Find(What:="*", _ After:=Rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function '<<========== Alt-F11 to open the VBA Editor Menu | Insert | Module | Paste the above code Alt-F11 to return to Excell Alt-F8 to open the Macros window Select "|Tester" | Run --- Regards. Norman "M.A.Tyler" <Great Lakes State wrote in message ... Failed to mention where I would like to put the information being moved. To Sheet"answers" starting in cell B4. Thanks again. "M.A.Tyler" wrote: I need to move the data contained in Sheet1,W:BB, in rows that Sheet1, Column D match Sheet"Answers" A3 and that Column BA (sheet1) contains 1. Can someone help with a method for performing this miracle? Thanks, M.A.Tyler |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to move data
Hi Mike,
Try: '========== Option Explicit Public Sub Tester() Dim WB As Workbook Dim SH As Worksheet Dim SH2 As Worksheet Dim Rng As Range Dim copyRng As Range Dim destRng As Range Dim iRow As Long Dim i As Long Dim CalcMode As Long Dim sStr As String Const dVal As Double = 1 Set WB = Workbooks("myBook.xls") '<<==== CHANGE With WB Set SH = .Sheets("Sheet1") Set SH2 = .Sheets("Answers") End With With SH2 sStr = .Range("A3") Set destRng = .Range("B4") End With With SH iRow = LastRow(SH, .Columns("A:A")) Set Rng = .Range("W1:BB" & iRow) End With On Error GoTo XIT With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With With SH For i = 1 To iRow If LCase(.Cells(i, "D").Value) = LCase(sStr) _ And .Cells(i, "BA").Value = dVal Then If copyRng Is Nothing Then Set copyRng = .Range(.Cells(i, "W"), _ .Cells(i, "BB")) Else Set copyRng = _ Union(.Range(.Cells(i, "W"), _ .Cells(i, "BB")), copyRng) End If End If Next i End With If Not copyRng Is Nothing Then copyRng.Copy Destination:=destRng Else 'nothing found, do nothing End If XIT: With Application .Calculation = CalcMode .ScreenUpdating = True End With End Sub '--------------- Function LastRow(SH As Worksheet, _ Optional Rng As Range) If Rng Is Nothing Then Set Rng = SH.Cells End If On Error Resume Next LastRow = Rng.Find(What:="*", _ After:=Rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function '<<========== --- Regards. Norman "M.A.Tyler" <Great Lakes State wrote in message ... Hi Norman, First let me thank you for your efforts, I certainly appreciate the help. I think we're close to the solution, just a couple tweeks. First there are two worksheets Sheet1 and "Answers". It's the first "assumtion" that is the problem. Column D value (in sheet1) must = value in sheet "Answers" cell A3 in addition too (second part) Sheet1 Column BA value = 1. Then you are correct, copy data for all rows in columns W:BB, where both criteria are met. Also I would prefer, that once copied, the original data be kept, as it is used from that location in subsequent calculations. I apologise for keeping you guessing, again thanks for the help! Regards, Mike. "Norman Jones" wrote: Hi M, I have assumed: that you want to copy data for all rows in columns W:BB whe - Column D value = "Answers" and - Column BA value = 1 I have further assumed that once copied, the original data is to be deleted. Assuming that this accords with your requirements, in a standard module (see below), paste the following code: '========== Option Explicit Public Sub Tester() Dim WB As Workbook Dim SH As Worksheet Dim Rng As Range Dim copyRng As Range Dim destRng As Range Dim iRow As Long Dim i As Long Dim CalcMode As Long Const sStr As String = "Answers" Const dVal As Double = 1 Set WB = Workbooks("myBook.xls") '<<==== CHANGE Set SH = WB.Sheets("Sheet1") '<<==== CHANGE Set destRng = WB.Sheets("Answers").Range("B4") With SH iRow = LastRow(SH, .Columns("A:A")) Set Rng = .Range("W1:BB" & iRow) End With On Error GoTo XIT With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With With SH For i = 1 To iRow If LCase(.Cells(i, "D").Value) = LCase(sStr) _ And .Cells(i, "BA").Value = dVal Then If copyRng Is Nothing Then Set copyRng = .Range(.Cells(i, "W"), _ .Cells(i, "BB")) Else Set copyRng = _ Union(.Range(.Cells(i, "W"), _ .Cells(i, "BB")), copyRng) End If End If Next i End With If Not copyRng Is Nothing Then copyRng.Copy Destination:=destRng copyRng.ClearContents Else 'nothing found, do nothing End If XIT: With Application .Calculation = CalcMode .ScreenUpdating = True End With End Sub '--------------- Function LastRow(SH As Worksheet, _ Optional Rng As Range) If Rng Is Nothing Then Set Rng = SH.Cells End If On Error Resume Next LastRow = Rng.Find(What:="*", _ After:=Rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function '<<========== Alt-F11 to open the VBA Editor Menu | Insert | Module | Paste the above code Alt-F11 to return to Excell Alt-F8 to open the Macros window Select "|Tester" | Run --- Regards. Norman "M.A.Tyler" <Great Lakes State wrote in message ... Failed to mention where I would like to put the information being moved. To Sheet"answers" starting in cell B4. Thanks again. "M.A.Tyler" wrote: I need to move the data contained in Sheet1,W:BB, in rows that Sheet1, Column D match Sheet"Answers" A3 and that Column BA (sheet1) contains 1. Can someone help with a method for performing this miracle? Thanks, M.A.Tyler |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to move data
Perfect, Made the one change and whala!
Can't Thank you enough Norman "Norman Jones" wrote: Hi Mike, Try: '========== Option Explicit Public Sub Tester() Dim WB As Workbook Dim SH As Worksheet Dim SH2 As Worksheet Dim Rng As Range Dim copyRng As Range Dim destRng As Range Dim iRow As Long Dim i As Long Dim CalcMode As Long Dim sStr As String Const dVal As Double = 1 Set WB = Workbooks("myBook.xls") '<<==== CHANGE With WB Set SH = .Sheets("Sheet1") Set SH2 = .Sheets("Answers") End With With SH2 sStr = .Range("A3") Set destRng = .Range("B4") End With With SH iRow = LastRow(SH, .Columns("A:A")) Set Rng = .Range("W1:BB" & iRow) End With On Error GoTo XIT With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With With SH For i = 1 To iRow If LCase(.Cells(i, "D").Value) = LCase(sStr) _ And .Cells(i, "BA").Value = dVal Then If copyRng Is Nothing Then Set copyRng = .Range(.Cells(i, "W"), _ .Cells(i, "BB")) Else Set copyRng = _ Union(.Range(.Cells(i, "W"), _ .Cells(i, "BB")), copyRng) End If End If Next i End With If Not copyRng Is Nothing Then copyRng.Copy Destination:=destRng Else 'nothing found, do nothing End If XIT: With Application .Calculation = CalcMode .ScreenUpdating = True End With End Sub '--------------- Function LastRow(SH As Worksheet, _ Optional Rng As Range) If Rng Is Nothing Then Set Rng = SH.Cells End If On Error Resume Next LastRow = Rng.Find(What:="*", _ After:=Rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function '<<========== --- Regards. Norman "M.A.Tyler" <Great Lakes State wrote in message ... Hi Norman, First let me thank you for your efforts, I certainly appreciate the help. I think we're close to the solution, just a couple tweeks. First there are two worksheets Sheet1 and "Answers". It's the first "assumtion" that is the problem. Column D value (in sheet1) must = value in sheet "Answers" cell A3 in addition too (second part) Sheet1 Column BA value = 1. Then you are correct, copy data for all rows in columns W:BB, where both criteria are met. Also I would prefer, that once copied, the original data be kept, as it is used from that location in subsequent calculations. I apologise for keeping you guessing, again thanks for the help! Regards, Mike. "Norman Jones" wrote: Hi M, I have assumed: that you want to copy data for all rows in columns W:BB whe - Column D value = "Answers" and - Column BA value = 1 I have further assumed that once copied, the original data is to be deleted. Assuming that this accords with your requirements, in a standard module (see below), paste the following code: '========== Option Explicit Public Sub Tester() Dim WB As Workbook Dim SH As Worksheet Dim Rng As Range Dim copyRng As Range Dim destRng As Range Dim iRow As Long Dim i As Long Dim CalcMode As Long Const sStr As String = "Answers" Const dVal As Double = 1 Set WB = Workbooks("myBook.xls") '<<==== CHANGE Set SH = WB.Sheets("Sheet1") '<<==== CHANGE Set destRng = WB.Sheets("Answers").Range("B4") With SH iRow = LastRow(SH, .Columns("A:A")) Set Rng = .Range("W1:BB" & iRow) End With On Error GoTo XIT With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With With SH For i = 1 To iRow If LCase(.Cells(i, "D").Value) = LCase(sStr) _ And .Cells(i, "BA").Value = dVal Then If copyRng Is Nothing Then Set copyRng = .Range(.Cells(i, "W"), _ .Cells(i, "BB")) Else Set copyRng = _ Union(.Range(.Cells(i, "W"), _ .Cells(i, "BB")), copyRng) End If End If Next i End With If Not copyRng Is Nothing Then copyRng.Copy Destination:=destRng copyRng.ClearContents Else 'nothing found, do nothing End If XIT: With Application .Calculation = CalcMode .ScreenUpdating = True End With End Sub '--------------- Function LastRow(SH As Worksheet, _ Optional Rng As Range) If Rng Is Nothing Then Set Rng = SH.Cells End If On Error Resume Next LastRow = Rng.Find(What:="*", _ After:=Rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function '<<========== Alt-F11 to open the VBA Editor Menu | Insert | Module | Paste the above code Alt-F11 to return to Excell Alt-F8 to open the Macros window Select "|Tester" | Run --- Regards. Norman "M.A.Tyler" <Great Lakes State wrote in message ... Failed to mention where I would like to put the information being moved. To Sheet"answers" starting in cell B4. Thanks again. "M.A.Tyler" wrote: I need to move the data contained in Sheet1,W:BB, in rows that Sheet1, Column D match Sheet"Answers" A3 and that Column BA (sheet1) contains 1. Can someone help with a method for performing this miracle? Thanks, M.A.Tyler |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to move data
Hi Norman,
While this works very well, I'm wondering if there is a way to expand it? So sStr would =Sheets("Answers") B3 (I moved that from A3) to also include "B" 14, 25, 36, 47, 58, 69, 80, 91, 102, 113 and 124. Likewise the destRng has been moved to column "J" to include row numbers 4, 15, 26, 37, 48, 59, 70, 81, 92, 103, 114 and 125. The criteria has remained the same needing a match in Sheet1 column "D" and column BA=1. Sorry for the headache, but I attempted to make these adjustments myself to no avail. Not quite savy enough to understand all of the code. Before I end up with several unnecessary modules for each macro, I thought it might be best to attempt expanding this one. I certainly apprieciate al of your help! Mike. "Norman Jones" wrote: Hi Mike, Try: '========== Option Explicit Public Sub Tester() Dim WB As Workbook Dim SH As Worksheet Dim SH2 As Worksheet Dim Rng As Range Dim copyRng As Range Dim destRng As Range Dim iRow As Long Dim i As Long Dim CalcMode As Long Dim sStr As String Const dVal As Double = 1 Set WB = Workbooks("myBook.xls") '<<==== CHANGE With WB Set SH = .Sheets("Sheet1") Set SH2 = .Sheets("Answers") End With With SH2 sStr = .Range("A3") Set destRng = .Range("B4") End With With SH iRow = LastRow(SH, .Columns("A:A")) Set Rng = .Range("W1:BB" & iRow) End With On Error GoTo XIT With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With With SH For i = 1 To iRow If LCase(.Cells(i, "D").Value) = LCase(sStr) _ And .Cells(i, "BA").Value = dVal Then If copyRng Is Nothing Then Set copyRng = .Range(.Cells(i, "W"), _ .Cells(i, "BB")) Else Set copyRng = _ Union(.Range(.Cells(i, "W"), _ .Cells(i, "BB")), copyRng) End If End If Next i End With If Not copyRng Is Nothing Then copyRng.Copy Destination:=destRng Else 'nothing found, do nothing End If XIT: With Application .Calculation = CalcMode .ScreenUpdating = True End With End Sub '--------------- Function LastRow(SH As Worksheet, _ Optional Rng As Range) If Rng Is Nothing Then Set Rng = SH.Cells End If On Error Resume Next LastRow = Rng.Find(What:="*", _ After:=Rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function '<<========== --- Regards. Norman "M.A.Tyler" <Great Lakes State wrote in message ... Hi Norman, First let me thank you for your efforts, I certainly appreciate the help. I think we're close to the solution, just a couple tweeks. First there are two worksheets Sheet1 and "Answers". It's the first "assumtion" that is the problem. Column D value (in sheet1) must = value in sheet "Answers" cell A3 in addition too (second part) Sheet1 Column BA value = 1. Then you are correct, copy data for all rows in columns W:BB, where both criteria are met. Also I would prefer, that once copied, the original data be kept, as it is used from that location in subsequent calculations. I apologise for keeping you guessing, again thanks for the help! Regards, Mike. "Norman Jones" wrote: Hi M, I have assumed: that you want to copy data for all rows in columns W:BB whe - Column D value = "Answers" and - Column BA value = 1 I have further assumed that once copied, the original data is to be deleted. Assuming that this accords with your requirements, in a standard module (see below), paste the following code: '========== Option Explicit Public Sub Tester() Dim WB As Workbook Dim SH As Worksheet Dim Rng As Range Dim copyRng As Range Dim destRng As Range Dim iRow As Long Dim i As Long Dim CalcMode As Long Const sStr As String = "Answers" Const dVal As Double = 1 Set WB = Workbooks("myBook.xls") '<<==== CHANGE Set SH = WB.Sheets("Sheet1") '<<==== CHANGE Set destRng = WB.Sheets("Answers").Range("B4") With SH iRow = LastRow(SH, .Columns("A:A")) Set Rng = .Range("W1:BB" & iRow) End With On Error GoTo XIT With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With With SH For i = 1 To iRow If LCase(.Cells(i, "D").Value) = LCase(sStr) _ And .Cells(i, "BA").Value = dVal Then If copyRng Is Nothing Then Set copyRng = .Range(.Cells(i, "W"), _ .Cells(i, "BB")) Else Set copyRng = _ Union(.Range(.Cells(i, "W"), _ .Cells(i, "BB")), copyRng) End If End If Next i End With If Not copyRng Is Nothing Then copyRng.Copy Destination:=destRng copyRng.ClearContents Else 'nothing found, do nothing End If XIT: With Application .Calculation = CalcMode .ScreenUpdating = True End With End Sub '--------------- Function LastRow(SH As Worksheet, _ Optional Rng As Range) If Rng Is Nothing Then Set Rng = SH.Cells End If On Error Resume Next LastRow = Rng.Find(What:="*", _ After:=Rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function '<<========== Alt-F11 to open the VBA Editor Menu | Insert | Module | Paste the above code Alt-F11 to return to Excell Alt-F8 to open the Macros window Select "|Tester" | Run --- Regards. Norman "M.A.Tyler" <Great Lakes State wrote in message ... Failed to mention where I would like to put the information being moved. To Sheet"answers" starting in cell B4. Thanks again. "M.A.Tyler" wrote: I need to move the data contained in Sheet1,W:BB, in rows that Sheet1, Column D match Sheet"Answers" A3 and that Column BA (sheet1) contains 1. Can someone help with a method for performing this miracle? Thanks, M.A.Tyler |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Move data Macro | Excel Discussion (Misc queries) | |||
Move data from tab to tab using a macro | Excel Programming | |||
Macro to move data to different column based on data in another co | Excel Discussion (Misc queries) | |||
enter data in cell which will start macro to move data to sheet2 | Excel Discussion (Misc queries) | |||
create macro to move label type data to column data | Excel Programming |