Question

我是VBA编码的新手，但设法摸索了。

我发现了这一点并修改了我的要求，但是我想指定要复制的列的范围，即A到Q。

任何帮助将不胜感激。

Sub SplitData_ToPLCSheets()
    'Split KEPServerCombined Column r into Separate Sheets ready for Export   (PLC Name)
    Const NameCol = "R"
    Const HeaderRow = 1
    Const FirstRow = 2
    Dim SrcSheet As Worksheet
    Dim TrgSheet As Worksheet
    Dim SrcRow As Long
    Dim LastRow As Long
    Dim TrgRow As Long
    Dim PLC As String
    Excel_Tools.TurnEverythingOff ' Turn off Calc , Screen Updating and `enter code here`Calcs
    Set SrcSheet = ThisWorkbook.Sheets("KEPServerCombined")
    'Set SrcSheet = ActiveSheet
    LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).row
    For SrcRow = FirstRow To LastRow
        PLC = SrcSheet.Cells(SrcRow, NameCol).value
        Set TrgSheet = Nothing
        On Error Resume Next
        Set TrgSheet = Worksheets(PLC)
        On Error GoTo 0
        If TrgSheet Is Nothing Then
            Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            TrgSheet.name = PLC
            SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
        End If
        TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).row + 1
        SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
    Next SrcRow
    Excel_Tools.TurnEverythingOn ' Turn on Calc , Screen Updating and Calcs
End Sub

Answer 1

感谢您的帮助-最终悬而未决了一个有效的答案，但速度慢了30000行

Sub SplitData_ToPLCSheets()

'Split KEPServerCombined Column r into Separate Sheets ready for Export (PLC Name)

  Const SrcCol_PLC = "R"
  Const SrcRow_Headers = 1
  Const SrcRow_FirstRow = 2
  Dim SrcSheet As Worksheet
  Dim TrgSheet As Worksheet
  Dim SrcRow As Long


  Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
  TrgSheet.name = TrgName
  SrcRange = "A" & Trim(Str(SrcRow_Headers)) & ":Q" & Trim(Str(SrcRow_Headers))
  TrgRange = "A1"
  SrcSheet.Range(SrcRange).Copy Destination:=TrgSheet.Range(TrgRange)

End If

' update the target row number to the first empty row on the target worksheet and copy data across

Set TrgSheet = Nothing
Set TrgSheet = Worksheets(TrgName)
TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, 1).End(xlUp).Offset(1).Row
SrcRange = "A" & Trim(Str(SrcRow)) & ":Q" & Trim(Str(SrcRow))
TrgRange = "A" & Trim(Str(TrgRow))
SrcSheet.Range(SrcRange).Copy Destination:=TrgSheet.Range(TrgRange)

SrcRow = SrcRow + 1
DoEvents
Loop
 Excel_Tools.TurnEverythingOn ' Turn on Calc , Screen Updating and Calcs

End Sub

Excel VBA将数据拆分为工作表

1 个答案: