Excel VBA Разделение данных на листы

Question

Я новичок в VBA Coding, но сумел пробиться.

Я нашел это и изменил в соответствии с моими требованиями, но я хочу указать диапазон столбцов для копирования от 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