将工作表拆分为多个工作表的代码

-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

将工作表拆分为多个工作表的代码

回答

相关问题