Macro to select certain cells & move data over 2 columns
Posted by Eric on November 14, 2001 6:24 AM
Financial spreadsheet contains lots of columns for entry by financial period. Some columns(for entry of dollar amounts) contain formulas as well as cells designated for data entry (call these "mixed" columns). The next column over from each of these contains only formulas. For instance, column C is mixed, column D is formula only, column E mixed, and so on. Spreadsheet is protected with only cells designated for data entry unlocked; these also have a yellow fill.
When I have a "mixed" column (or any cell in that column)selected, I need a macro which will:
1) Select the data cells, cut the data, and move it over 2 columns (ie to the next "mixed" column). The cells receiving the data should be empty; if possible the macro should alert the user if they do already contain data and provide the option to cancel the process.
Thanks.
Posted by Rick E on November 14, 2001 9:50 AM
Here is the macro:
Sub MoveIt()
'
str1 = ActiveWindow.RangeSelection.Address(ReferenceStyle:=xlR1C1)
i = ActiveWindow.RangeSelection.Count
If i = 1 Then
If ActiveCell.Offset(0, 2).Value <> "" Then
x = MsgBox("Copy to cell is not empty, copy anyway?", vbExclamation + vbYesNo, "Copy Check")
If x = 7 Then Exit Sub
End If
Else
rowX = ""
j = 2
k = 0
Do Until k = 1
str2 = Mid(str1, j, 1)
If IsNumeric(str2) Then
rowX = rowX & str2
j = j + 1
Else
k = 1
End If
Loop
columnX = ""
j = 1
Do Until k = 0
j = j + 1
str2 = Mid(str1, j, 1)
If str2 = "C" Then
j = j + 1
k = 0
End If
Loop
Do Until k = 1
str2 = Mid(str1, j, 1)
If IsNumeric(str2) Then
columnX = columnX & str2
j = j + 1
Else
k = 1
End If
Loop
str2 = Chr(64 + columnX + 2) & rowX
Range(str2).Select
For j = 1 To i
If ActiveCell.Value <> "" Then
x = MsgBox("Copy to cells are not empty, copy anyway?", vbExclamation + vbYesNo, "Copy Check")
If x = 7 Then
Exit Sub
Else
Exit For
End If
End If
ActiveCell.Offset(1, 0).Select
Next j
str2 = Chr(64 + columnX) & rowX & ":" & Chr(64 + columnX) & rowX + i - 1
Range(str2).Select
End If
Selection.Copy
If i = 1 Then
ActiveCell.Offset(0, 2).Select
Else
str2 = Chr(64 + columnX + 2) & rowX
Range(str2).Select
End If
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
If i = 1 Then
ActiveCell.Offset(0, -2).Select
Else
str2 = Chr(64 + columnX) & rowX & ":" & Chr(64 + columnX) & rowX + i - 1
Range(str2).Select
End If
End Sub
Sorry, there are no comments, hope this does it for you. Just copy this to a module in the workbook. Select what you want to move and the macro will do the ckeck in the column 2 over and move what you have selected.
Rick E.
