Vba 将某个单元格的多个部分复制到另一个工作表（一步完成）

假设我有一个包含原始数据的.txt文档，如下所示：

20180214abcdfhkjvdafhkkjgbv trewfdgjklmbv
20180213fjgmhjlkjlkmghjdfdshkjlkjlkjlkjas
20180215qewwqretiumnbsfdljf erwuoiukjhjjk

2018---02---14---abcd---fhkjvda---fhkkjg---bv ---trew---fdgjklmbv
2018---02---13---fjgm---hjlkjlk---mghjdf---dsh---kjlk---jlkjlkjas
2018---02---15---qeww---qretium---nbsfdl---jf ---erwu---oiukjhjjk

   For i = 1 To lastRow
      ActiveWorkbook.Sheets("sht1").Range("A" & (i + firstRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & i).Value, 1, 4)
      ActiveWorkbook.Sheets("sht1").Range("B" & (i + firstRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & i).Value, 5, 2)
      ActiveWorkbook.Sheets("sht1").Range("C" & (i + firstRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & i).Value, 7, 1)
   Next

 ActiveWorkbook.Sheets("sht1").Range("A" & (firstRow) & ":" & "A" & (firstRow + lastRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & 1 & ":" & "A" & lastRow).Value, 1, 4)

但是有超过23500行。我需要将这些信息分成不同的列，如下所示：

20180214abcdfhkjvdafhkkjgbv trewfdgjklmbv
20180213fjgmhjlkjlkmghjdfdshkjlkjlkjlkjas
20180215qewwqretiumnbsfdljf erwuoiukjhjjk

2018---02---14---abcd---fhkjvda---fhkkjg---bv ---trew---fdgjklmbv
2018---02---13---fjgm---hjlkjlk---mghjdf---dsh---kjlk---jlkjlkjas
2018---02---15---qeww---qretium---nbsfdl---jf ---erwu---oiukjhjjk

   For i = 1 To lastRow
      ActiveWorkbook.Sheets("sht1").Range("A" & (i + firstRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & i).Value, 1, 4)
      ActiveWorkbook.Sheets("sht1").Range("B" & (i + firstRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & i).Value, 5, 2)
      ActiveWorkbook.Sheets("sht1").Range("C" & (i + firstRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & i).Value, 7, 1)
   Next

 ActiveWorkbook.Sheets("sht1").Range("A" & (firstRow) & ":" & "A" & (firstRow + lastRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & 1 & ":" & "A" & lastRow).Value, 1, 4)

其中---表示“另一列”哈哈

这就是我所做的：

• 首先，我将所有原始数据复制到Excel中的工作表中

• 然后，我将信息拆分到另一张纸中，如下所示：

  20180214abcdfhkjvdafhkkjgbv trewfdgjklmbv
  20180213fjgmhjlkjlkmghjdfdshkjlkjlkjlkjas
  20180215qewwqretiumnbsfdljf erwuoiukjhjjk
  

  2018---02---14---abcd---fhkjvda---fhkkjg---bv ---trew---fdgjklmbv
  2018---02---13---fjgm---hjlkjlk---mghjdf---dsh---kjlk---jlkjlkjas
  2018---02---15---qeww---qretium---nbsfdl---jf ---erwu---oiukjhjjk
  

     For i = 1 To lastRow
        ActiveWorkbook.Sheets("sht1").Range("A" & (i + firstRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & i).Value, 1, 4)
        ActiveWorkbook.Sheets("sht1").Range("B" & (i + firstRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & i).Value, 5, 2)
        ActiveWorkbook.Sheets("sht1").Range("C" & (i + firstRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & i).Value, 7, 1)
     Next
  

   ActiveWorkbook.Sheets("sht1").Range("A" & (firstRow) & ":" & "A" & (firstRow + lastRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & 1 & ":" & "A" & lastRow).Value, 1, 4)
  

但这太长了（比如10分钟，因为有23500多行，然后我做了一张桌子，做了很多其他的事情）

所以，我需要这样的东西：“从所有这些单元格中提取这些字符，并将它们粘贴到所有其他单元格中”。大概是这样的：

20180214abcdfhkjvdafhkkjgbv trewfdgjklmbv
20180213fjgmhjlkjlkmghjdfdshkjlkjlkjlkjas
20180215qewwqretiumnbsfdljf erwuoiukjhjjk

2018---02---14---abcd---fhkjvda---fhkkjg---bv ---trew---fdgjklmbv
2018---02---13---fjgm---hjlkjlk---mghjdf---dsh---kjlk---jlkjlkjas
2018---02---15---qeww---qretium---nbsfdl---jf ---erwu---oiukjhjjk

   For i = 1 To lastRow
      ActiveWorkbook.Sheets("sht1").Range("A" & (i + firstRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & i).Value, 1, 4)
      ActiveWorkbook.Sheets("sht1").Range("B" & (i + firstRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & i).Value, 5, 2)
      ActiveWorkbook.Sheets("sht1").Range("C" & (i + firstRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & i).Value, 7, 1)
   Next

 ActiveWorkbook.Sheets("sht1").Range("A" & (firstRow) & ":" & "A" & (firstRow + lastRow)).Value = Mid(ActiveWorkbook.Sheets("rawData").Range("A" & 1 & ":" & "A" & lastRow).Value, 1, 4)

但这不起作用

它的工作原理如下：

ActiveWorkbook.Sheets("sht1").Range("A" & (firstRow) & ":" & "A" & (firstRow + lastRow)).Value = 0

但是，我想将前面提到的字符（例如，Mid（…，8,12）替换为“0”

---

我找不到任何解决方案，我真的需要它。谢谢：D

文本到列似乎是一种权宜之计

Option Explicit

Sub splitDogsBreakfast()
    With Worksheets("rawData")
        With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp))
            worksheets("sht1").cells(1, "A").resize(.rows.count, 1) = .value2
        end wth
    end with
    With Worksheets("sht1")
        With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp))
            .TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, _
                FieldInfo:=Array(Array(0, 1), Array(4, 1), Array(6, 1), Array(8, 1), Array(12, 1), _
                                 Array(19, 1), Array(25, 1), Array(28, 1), Array(32, 1))
        End With
    End With
End Sub

---

数据选项卡上也有相同的命令。

文本到列似乎是一种方便的方法

Option Explicit

Sub splitDogsBreakfast()
    With Worksheets("rawData")
        With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp))
            worksheets("sht1").cells(1, "A").resize(.rows.count, 1) = .value2
        end wth
    end with
    With Worksheets("sht1")
        With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp))
            .TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, _
                FieldInfo:=Array(Array(0, 1), Array(4, 1), Array(6, 1), Array(8, 1), Array(12, 1), _
                                 Array(19, 1), Array(25, 1), Array(28, 1), Array(32, 1))
        End With
    End With
End Sub

---

数据选项卡上也有相同的命令。

也许

Range.Parse

方法会很有用，除了它会删除任何前导零之外

要将其移动到另一张图纸，在执行“拆分”之前，只需将旧图纸的范围复制到新图纸，然后在新图纸上执行拆分

Option Explicit
Sub ParseSpecial()
    Dim wsSrc As Worksheet
    Dim rSrc As Range

Set wsSrc = Worksheets("Sheet1")
With wsSrc
    Set rSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With


rSrc.Parse _
    parseline:="[xxxx][xx][xx][xxxx][xxxxxxx][xxxxxx][xxx][xxxx][xxxxxxxxxx]", _
    Destination:=wsSrc.Range("B1")

End Sub

---

也许

Range.Parse

方法会有用，除了它会删除任何前导零之外

要将其移动到另一张图纸，在执行“拆分”之前，只需将旧图纸的范围复制到新图纸，然后在新图纸上执行拆分

Option Explicit
Sub ParseSpecial()
    Dim wsSrc As Worksheet
    Dim rSrc As Range

Set wsSrc = Worksheets("Sheet1")
With wsSrc
    Set rSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With


rSrc.Parse _
    parseline:="[xxxx][xx][xx][xxxx][xxxxxxx][xxxxxx][xxx][xxxx][xxxxxxxxxx]", _
    Destination:=wsSrc.Range("B1")

End Sub

---

---

但是我需要将一个单元格（例如A1）的信息拆分为多个单元格（例如B1:Z1），所以您想说的是，您希望保留原始单元格，而不是用第一个段覆盖它…？我想这样做：ActiveWorkbook.Sheets（“sht1”）.Range（“A”&（firstRow）&“&“A”&（firstRow+lastRow））.Value=Mid（ActiveWorkbook.Sheets（“rawData”）.Range（“A”&1&“：”&“A”&lastRow）.Value，1，4）我的意思是，复制单元格A1:A1000中另一个工作表中A1:A1000范围内的字符9-12，然后复制单元格A1:A1000中A1:A1000范围内的字符12-19，从第一个工作表复制到另一个工作表中的单元格B1:B1000，所以现在您只需要第一个段（例如2018年）将原始数据工作表中的数据放入sht1工作表中，并丢弃其余的数据？我有以下信息：20180214abcdfhkjvdafhkkjgbv trewfdgjklmbv位于工作表“rawData”的单元格A1中。我想将其粘贴在工作表“sht1”中，如下所示：A1:2018、B1:02、B2:14……但我需要将一个单元格（例如A1）的信息拆分为多个单元格（例如，B1:Z1）那么您想说的是，您想保留原始文件，而不是用第一个段覆盖它…？我想这样做：ActiveWorkbook.Sheets（“sht1”）.Range（“A”&（firstRow）&“：”&“A”&（firstRow+lastRow））.Value=Mid（ActiveWorkbook.Sheets（“rawData”）.Range（“A”&“A”&“A”&“A”&lastRow”）.Value，1,4）我的意思是，例如，将A1:A1000范围内的字符9-12复制到A1:A1000单元格中的另一个工作表中，然后将A1:A1000范围内的字符12-19从第一个工作表复制到另一个工作表中的B1:B1000单元格中，因此现在您只需要第一个段（例如2018）从rawData工作表中放入sht1工作表并丢弃其余的？我有这个：20180214abcdfhkjvdafhkkjgbv trewfdgjklmbv在表格“rawData”的A1单元格中。我想把它粘贴在表格“sht1”中，像这样：A1:2018，B1:02，B2:14……我相信第三个

[xx]

应该是

[xxx]

@jeped感谢您的选择。（一旦我意识到你的意思是从结尾算起的第三个元素，而不是从一开始算起）。实际上我的意思是‘有两个x的第三个元素应该有三个x’，但你还是到了那里。如果我想在另一张表中超过它，为什么目标：=工作表（“Sheet2”）。范围（“B1”）不起作用？我怎么做？@acceExcessel

Range.Copy

方法复制到新的工作表。然后

Range.Parse

方法在新的工作表上我相信第三个

[xx]

应该是

[xxx]

@Jeeped谢谢你选择它。（一旦我意识到你指的是从最后开始的第三个，而不是从开始的第三个）。实际上，我的意思是‘第三个元素有两个x’应该有三个x’，但你还是得到了。如果我想在另一张工作表中通过它，为什么目标：=工作表（“Sheet2”）。范围（“B1”）不起作用？我该怎么做？@acceExcessel

Range.Copy

方法复制到新工作表中。然后在新工作表上使用

Range.Parse

方法