Question

在这里给Newb排名。所以，这就是问题所在：我有一个简单的一维单元格列，其中包含文本。我想执行以下操作：

从字符串中剥离“ .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()
    Dim MyCell As Range
    For Each MyCell In Selection
        If MyCell.Value <> "" Then
            MyCell.Copy
            MyCell.Offset(1, 0).Insert shift:=xlDown
            MyCell.Offset(2, 0).Select
        End If
    Next MyCell
End Sub

Answer 1

这对您有用吗？

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

Answer 2

这对我来说听起来像是不良的数据结构（插入行），因此此解决方案将基于列结构化表。但是，我对数据了解不多，因此对我而言这可能是一个错误的假设。

您可以将值存储在列中，而不是像| Original String | .jpg | -Alpha.tif |

Original String是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

Answer 3

Trim160ConcatArrayPaste

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: &nbsp;) 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 ======================================================================

Excel VBA看似简单的问题：在选定范围上修剪，复制（插入），Concat

3 个答案:

Trim160ConcatArrayPaste