Excel 修剪、复制（插入）、在选定范围上连接

我有一个包含文本的一维单元格列

我想：

带“.jpg”扩展名

复制每一行并在其下方插入复制行的副本

对于每个重复的行（每第二行），添加后缀“-Alpha”

将“.tif”扩展名应用于所有单元格

数据如下所示：

0120-052.jpg 
0120-053.jpg 
0120-054.jpg 
0120-055.jpg 
0120-056.jpg 

我想选择该范围，其显示方式如下：

0120-052.tif 
0120-052-Alpha.tif 
0120-053.tif 
0120-053-Alpha.tif 
0120-054.tif 
0120-054-Alpha.tif 
0120-055.tif 
0120-055-Alpha.tif 
0120-056.tif 
0120-056-Alpha.tif 

我发现了如何在现有数据之间插入整行，但在该数据的左侧有其他数据，不希望在整个电子表格中出现空白行。我确实找到了在现有数据之间插入空格的方法，但我不知道如何在插入时粘贴数据。我把一些东西混在一起，但它试图无限粘贴

我想我需要把它全部放到一个数组中，然后一步一步地迭代，但是我无法根据任意的选择找出如何做到这一点

Sub-PasteInsertRowsAfter（）
暗淡的迈塞尔山脉
对于选择中的每个菌丝体
如果MyCell.Value为“”，则
迈塞尔，收到
MyCell.Offset（1，0）.插入移位：=xlDown
迈塞尔偏移量（2，0）。选择
如果结束
下一个迈塞尔
端接头

这对你有用吗

Sub PasteInsertRowsAfter()
Dim i As Long
Dim MyCell As Range
Dim Rng As Range

Set Rng = Selection

For i = Rng.Cells.Count To 1 Step -1
    Set MyCell = Rng.Cells(i)
    MyCell.Copy
    MyCell.Offset(1, 0).Insert shift:=xlDown
    MyCell.Value = Replace(MyCell.Value, ".jpg", ".tif")
    MyCell.Offset(1, 0).Value = Replace(MyCell.Offset(1, 0), ".jpg", "-Alpha.tif")
Next i
End Sub

---

这听起来像是糟糕的数据结构（插入行），所以这个解决方案将基于一个列结构的表。然而，我对数据了解不多，所以这可能是我的错误假设

---

您可以将值存储在列中，例如so

| Original String |.jpg |-Alpha.tif |

其中，

原始字符串

是列A的标题，依此类推。这样可以更好地组织数据，因为原始字符串的所有修改都将存储在一行中。此结构允许您添加在某个时间点（来源、日期等）可能相关的其他信息。您可以使用此格式创建轴，并更轻松地监视重复项。您甚至可以存储原始字符串

宏的输入/输出如下所示

此子循环是一个简单的循环，不采用

Slection

范围

Sub Alternative()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim MyRange As Range: Set MyRange = ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
Dim MyCell As Range

Application.ScreenUpdating = False
    For Each MyCell In MyRange
        MyCell.Offset(, 1) = Replace(MyCell, "jpg", "tif")
        MyCell.Offset(, 2) = Replace(MyCell, ".jpg", "-Alpha.tif")
    Next MyCell
Application.ScreenUpdating = True

End Sub

---

这里有一个选项，允许用户在启动宏后选择一个范围。与上述解决方案一样，宏将输出选定范围左侧2列中的数据

Sub Alternative()

Dim MyRange As Range, MyCell As Range

On Error Resume Next 'Allow for Cancel Button
    Set MyRange = Application.InputBox("Select Range", Type:=8)
On Error GoTo 0

If Not MyRange Is Nothing Then
    Application.ScreenUpdating = False
        For Each MyCell In MyRange
            MyCell.Offset(, 1) = Replace(MyCell, "jpg", "tif")
            MyCell.Offset(, 2) = Replace(MyCell, ".jpg", "-Alpha.tif")
        Next MyCell
    Application.ScreenUpdating = True
End If

End Sub

三聚体

---

似乎您最好将输出放在一个新列中，以便它们并排显示。这样数据组织得更好。如果你愿意，我可以提供一个解决方案！我知道有一个非常简单的解决方案！先生，我向你致敬。谢谢你的帮助@新手，不客气！很高兴它能按预期工作。感谢您的反馈。：）哇，VBasic208。非常令人印象深刻。它也很有魅力，我真的很欣赏所有注释过的代码，并给出了详尽的解释。我觉得代码本身就是一个完整的教程！我相信你在某个地方是一位很棒的老师。再次感谢您慷慨的教程和工具！感谢您的评论、解释和代码。我同意，对于大多数应用程序来说，这将被视为“糟糕的数据结构”（特别是有可能无意中覆盖/丢失数据）。幸运的是，这是一个非常不寻常的情况，我让用户选择现有的，计算数据范围，复制并粘贴该数据，然后在选定范围内运行此VBA位。因此，原始数据永远不会有危险，这只是将数据调整为另一个程序所需格式的一小步（但至关重要）

Option Explicit
'With Sub ======================================================================
'  .Title: Trim160ConcatArrayPaste
'  .Author: YMG
'-------------------------------------------------------------------------------
Sub Trim160ConcatArrayPaste()
'Description
'  Manipulates data in a selected worksheet range and pastes the result into
'  another range (overwriting the former range and more).
'Parameters
'  None
'Returns
'  Manipulated data in a range.
'
'-- Customize BEGIN --------------------
  Const cStr1 As String = ".jpg"
  Const cStr2 As String = ".tif"
  Const cStr3 As String = "-Alpha.tif"
  'If the result should be pasted into another row. Probably useless.
  Const loROff As Long = 0 'Row Offset for Array Data
''''''''''''''''''''''''''''''''''''''''
  'If the result should be pasted into another column
  Const iCOff As Integer = 0 'Column Offset for Array Data
  'Remarks:
  '  I strongly urge you to consider pasting the data into another column e.g.
  '  the column adjacent to the right of the starting column (Set iCoff = 1).
  '  If something goes wrong while pasting you will overwrite your initial data
  '  and you might lose a lot of time getting it back.
  '  Creating a log file might be considered.
''''''''''''''''''''''''''''''''''''''''
'
'-- Customize END ----------------------
'
  Dim oXL As Application 'Exel Application Object
  Dim oWb As Workbook 'Workbook Object - ActiveWorkbook
  Dim oWs As Worksheet 'Worksheet Object - ActiveSheet
  Dim oRng As Range 'Range Object - Range to read from, Range to write to
  Dim oCell As Range 'Cell - Range Object - All cells of oRng
  Dim arrTCC() As String
  Dim lo1 As Long 'Data Entries Counter, Array Entries Counter
  Dim strCell As String
  Dim strArrRng As String
'
'-------------------------------------------------------------------------------
'Assumptions
'  There is a contiguous range (oRng) in the ActiveSheet (oWs) of the
'  ActiveWorkbook (oWb) that contains a list of entries in its cells
'  (oRng.Cells) to be processed. ('Data' for 'list of entries' in further text)
'  The actual range of the Data is selected.
'-------------------------------------------------------------------------------
'
  Set oXL = Application
  Set oWb = ActiveWorkbook
  Set oWs = oWb.ActiveSheet
  Set oRng = oXL.Selection
'
  'Remarks:
  '  The Selection Property is a property of the Application object and the
  '  Window object. Visual Basic doesn't allow ActiveWorkbook.Selection or
  '  ActiveSheet.Selection.
'
''''''''''''''''''''''''''''''''''''''''
  'Task:
  '  Count the number of Data entries.
'
  lo1 = 0 'Data Entries Counter
  For Each oCell In oRng.Cells
    lo1 = lo1 + 1
  Next
'
  'Status:
  '  'lo1' is the number of Data entries which will be used to determine the
  '  size of an array in the following code.
'
''''''''''''''''''''''''''''''''''''''''
  'Task: Populate an array with the desired results.
'
  ReDim arrTCC(1 To lo1 * 2, 1 To 1)
  'Explaination:
    '"lo1" - Number of list entries.
    '" * 2" - Making 2 entries out of each entry.
  lo1 = 0 'Array Entries Counter (This is a 1-based array.)
  For Each oCell In oRng.Cells
    'Clean the text of the Data entries.
    strCell = Trim(oCell.Text)
    'Remarks:
      'Chr(160) which is a non-breaking space (HTML Name:  ) is at
      'the end of the Data entries. The Trim function doen't clean
      'non-breaking spaces.
    strCell = Replace(strCell, Chr(160), "")
      'Check the last part of the string
    If Right(strCell, Len(cStr1)) = cStr1 Then
      'Populate array.
      lo1 = lo1 + 1
      arrTCC(lo1, 1) = Replace(strCell, cStr1, cStr2)
      lo1 = lo1 + 1
      arrTCC(lo1, 1) = Replace(strCell, cStr1, cStr3)
     'If the cell doesn't end with cStr1:
     Else 'This should never happen, remember: COUNTIGUOUS.
      'An Idea
'      lo1 = lo1 + 1
'      arrTCC(lo1, 1) = ""
'      lo1 = lo1 + 1
'      arrTCC(lo1, 1) = ""
      MsgBox "You might have selected a wrong range.", vbCritical
      Exit Sub
    End If
  Next
'
'  For lo1 = LBound(arrTCC) To UBound(arrTCC)
'    Debug.Print arrTCC(lo1, 1)
'  Next
'  Debug.Print LBound(arrTCC)
'  Debug.Print UBound(arrTCC)
'
  'Status: The array 'arrTCC' is populated
'
''''''''''''''''''''''''''''''''''''''''
  'Task:
  '  Determine the range where to paste the data from array and paste the
  '  array into the range.
'
  'Calculate the 'Start' Cell Address
  strArrRng = oRng.Cells(1 + loROff, 1 + iCOff).Address
'
'  Debug.Print strArrRng
'
  'Add the ":" (Address Separator) and the Calculated 'End' Cell Address
  strArrRng = strArrRng & ":" & _
    oRng.Cells(UBound(arrTCC) + loROff, 1 + iCOff).Address
  'Paste the Array to the Worksheet
  Set oRng = oWs.Range(strArrRng)
'
'  Debug.Print strArrRng
'  Debug.Print oRng.Address
'
  oRng = arrTCC
'
  'Status: Done
'
  'Remarks:
    'Testing the program was done with iCoff = 1 i.e. pasting the array data
    'into the column adjacent to the right of the starting column. Since it uses
    'overwriting the Data, the Data would always need to be written back for
    'further testing.
    'Some debugging code has deliberately been commented and left inside the
    'program to remind amateurs like myself of debugging importance.
    'Some other aspects of this program could be considered like the column
    'of the data could be known or unknown so a range, a column or the
    'ActiveCell would have or don't have to be selected etc.
'
End Sub
'-------------------------------------------------------------------------------
'With Source Idea --------------------------------------------------------------
'  .Title: Excel VBA seemingly simple problem: Trim, Copy (insert), Concat on selected range
'  .TitleLink: https://stackoverflow.com/questions/52548294/excel-vba-seemingly-simple-problem-trim-copy-insert-concat-on-selected-rang
'  .Author: NewbieStackOr
'  .AuthorLink: https://stackoverflow.com/users/10427336/newbiestackor
'End With ----------------------------------------------------------------------
'End With ======================================================================