將工作表拆分爲多個工作表的代碼

-1

將工作表拆分爲多個工作表的代碼。但是，這是問題所在。當我運行它。它給我空白工作表，並沒有把數據放入這些工作表。將工作表拆分爲多個工作表的代碼

下面是代碼：

Sub parse_data() 
    Dim lr As Long 
    Dim ws As Worksheet 
    Dim vcol, i As Integer 
    Dim icol As Long 
    Dim myarr As Variant 
    Dim title As String 
    Dim titlerow As Integer 
    vcol = 2 
    Set ws = Sheets("AdHocReport_course (2)") 
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row 
    title = "A1:Y1" 
    titlerow = ws.Range(title).Cells(1).Row 
    icol = ws.Columns.Count 
    ws.Cells(1, icol) = "Unique" 
    For i = 2 To lr 
     On Error Resume Next 
     If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then 
      ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol) 
     End If 
    Next 
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants)) 
    ws.Columns(icol).Clear 
    For i = 2 To UBound(myarr) 
     ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "" 
     If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then 
      Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" 
     Else 
      Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count) 
     End If 
     ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1") 
     Sheets(myarr(i) & "").Columns.AutoFit 
    Next 
    ws.AutoFilterMode = False 
    ws.Activate 
End Sub

來源

2016-11-07 user3509198

對此進行評論'On Error Resume Next' - 您是否收到錯誤消息？請在發佈代碼時，**縮進它**，以便更容易閱讀。代碼適用於我的FWIW， –

。 B列中有哪些數據？用作工作表名稱時，是否有任何值是有效的？ – YowE3K

很難說，如果這是你的問題，但：

If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then

如果使用默認Application.Evaluate形式的Evaluate那麼它將在上下文計算公式的活頁：使用工作表格形式會更安全：

If Not ws.Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then

那麼它將使用ws作爲上下文。

來源

2016-11-07 20:02:58

將工作表拆分爲多個工作表的代碼

回答

相關問題