Moves strings within cells into other cells, move or copy.
Specific task to copy or move strings in cells with special structure, check screenshot.
+++ can be enhanced to be used wider.
Sub Edgar_CopyFields_FromTo_Batch()
' Move (or Copy) certain field, from Section to Section
' As batch
' I5 No of employees From Sec3 to Sec1
' EF5 | EF6 | EF23 | EF30 | EF31 | EF34 | HJ60
' From Sec3 to Sec2
'
CellsArr = ""
' CellsArr = "I5" ' Move from Sec3 to Sec1
' CellsArr = "E5|F5|H60|J60" ' Move from Sec3 to Sec2
CellsArr = "E6|F6|E23|F23|E30|F30|E31|F31|E34|F34" ' Copy from Sec3 to Sec2
C1M2 = 1 ' 1 for copy, 2 to move
SecFrom = 3
SecTo = 2
If CellsArr = "" Then Exit Sub
Application.Calculation = xlCalculationManual
For Each Cell1 In Split(CellsArr, "|")
Cell1 = Trim(Cell1)
Edgar_CopyMoveText_FromTo Cell1, SecFrom, SecTo, C1M2
Next
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Edgar_CopyMoveText_FromTo(FieldCell, FromSecID, ToSecID, Optional Copy1_or_Move2 = 2)
'
' Move certain field, from Section to Section
'
ToSecRow = 0
NRows = ShNotes.Range("A1").CurrentRegion.Rows.Count
X1 = 2
Do Until X1 > NRows
CompName = ShNotes.Range("A" & X1).Value
CompNoteID = Val(ShNotes.Range("B" & X1).Value)
If CompName = "" Then GoTo NextNRow
HaveNotes = WorksheetFunction.CountA(ShNotes.Range("D" & X1, "AZ" & X1))
If HaveNotes = 0 Then GoTo NextNRow
If ToSecRow = 0 Or CompNoteID = 1 Then ToSecRow = X1
ToSecHead = ShNotes.Range("D1").Offset(, (ToSecID - 1) * 2).Value
ToSec = ShNotes.Range("D" & ToSecRow).Offset(, (ToSecID - 1) * 2).Value
FromSecHead = ShNotes.Range("D1").Offset(, (FromSecID - 1) * 2).Value
FromSec = ShNotes.Range("D" & X1).Offset(, (FromSecID - 1) * 2).Value
HaveField = VBInstr(FieldCell & "=", FromSec)
If HaveField = 0 Then GoTo NextNRow
FieldRule = Mid(FromSec, HaveField)
FieldRule = CutString(FieldRule, , "{$F$}")
If FieldRule = FromSec Then GoTo NextNRow
ToSec = ToSec & IIf(ToSec > "", "{$F$}", "") & FieldRule
If Copy1_or_Move2 = 2 Then
FromSec = Replace(FromSec, FieldRule, "")
FromSec = Replace(FromSec, "{$F$}{$F$}{$F$}", "{$F$}") ' possible duplication generated by replace above
FromSec = Replace(FromSec, "{$F$}{$F$}", "{$F$}") ' possible duplication generated by replace above
If Left(FromSec, 5) = "{$F$}" Then FromSec = Mid(FromSec, 6)
If Right(FromSec, 5) = "{$F$}" Then FromSec = Left(FromSec, Len(FromSec) - 5)
ShNotes.Range("D" & X1).Offset(, (FromSecID - 1) * 2).Value = FromSec
End If
ShNotes.Range("D" & ToSecRow).Offset(, (ToSecID - 1) * 2).Value = ToSec
ToSecRow = 0
NextNRow:
X1 = X1 + 1
DoEvents
Loop
End Sub
' Move (or Copy) certain field, from Section to Section
' As batch
' I5 No of employees From Sec3 to Sec1
' EF5 | EF6 | EF23 | EF30 | EF31 | EF34 | HJ60
' From Sec3 to Sec2
'
CellsArr = ""
' CellsArr = "I5" ' Move from Sec3 to Sec1
' CellsArr = "E5|F5|H60|J60" ' Move from Sec3 to Sec2
CellsArr = "E6|F6|E23|F23|E30|F30|E31|F31|E34|F34" ' Copy from Sec3 to Sec2
C1M2 = 1 ' 1 for copy, 2 to move
SecFrom = 3
SecTo = 2
If CellsArr = "" Then Exit Sub
Application.Calculation = xlCalculationManual
For Each Cell1 In Split(CellsArr, "|")
Cell1 = Trim(Cell1)
Edgar_CopyMoveText_FromTo Cell1, SecFrom, SecTo, C1M2
Next
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Edgar_CopyMoveText_FromTo(FieldCell, FromSecID, ToSecID, Optional Copy1_or_Move2 = 2)
'
' Move certain field, from Section to Section
'
ToSecRow = 0
NRows = ShNotes.Range("A1").CurrentRegion.Rows.Count
X1 = 2
Do Until X1 > NRows
CompName = ShNotes.Range("A" & X1).Value
CompNoteID = Val(ShNotes.Range("B" & X1).Value)
If CompName = "" Then GoTo NextNRow
HaveNotes = WorksheetFunction.CountA(ShNotes.Range("D" & X1, "AZ" & X1))
If HaveNotes = 0 Then GoTo NextNRow
If ToSecRow = 0 Or CompNoteID = 1 Then ToSecRow = X1
ToSecHead = ShNotes.Range("D1").Offset(, (ToSecID - 1) * 2).Value
ToSec = ShNotes.Range("D" & ToSecRow).Offset(, (ToSecID - 1) * 2).Value
FromSecHead = ShNotes.Range("D1").Offset(, (FromSecID - 1) * 2).Value
FromSec = ShNotes.Range("D" & X1).Offset(, (FromSecID - 1) * 2).Value
HaveField = VBInstr(FieldCell & "=", FromSec)
If HaveField = 0 Then GoTo NextNRow
FieldRule = Mid(FromSec, HaveField)
FieldRule = CutString(FieldRule, , "{$F$}")
If FieldRule = FromSec Then GoTo NextNRow
ToSec = ToSec & IIf(ToSec > "", "{$F$}", "") & FieldRule
If Copy1_or_Move2 = 2 Then
FromSec = Replace(FromSec, FieldRule, "")
FromSec = Replace(FromSec, "{$F$}{$F$}{$F$}", "{$F$}") ' possible duplication generated by replace above
FromSec = Replace(FromSec, "{$F$}{$F$}", "{$F$}") ' possible duplication generated by replace above
If Left(FromSec, 5) = "{$F$}" Then FromSec = Mid(FromSec, 6)
If Right(FromSec, 5) = "{$F$}" Then FromSec = Left(FromSec, Len(FromSec) - 5)
ShNotes.Range("D" & X1).Offset(, (FromSecID - 1) * 2).Value = FromSec
End If
ShNotes.Range("D" & ToSecRow).Offset(, (ToSecID - 1) * 2).Value = ToSec
ToSecRow = 0
NextNRow:
X1 = X1 + 1
DoEvents
Loop
End Sub
FieldCell, FromSecID, ToSecID, Optional Copy1_or_Move2 = 2
Views 714
Downloads 54
CodeID
DB ID