返回列表 上一主題 發帖

[發問] 分割資料成為新增工作表

回復 1# b9208
  1. Sub Split_Sheet()
  2. Dim Rng As Range, A As Range
  3. Application.DisplayAlerts = False
  4. With Sheets("WW")
  5. .Select
  6. p = ActiveWindow.Zoom
  7. For Each sht In Sheets
  8. If sht.Name <> .Name Then sht.Delete
  9. Next
  10. For Each A In .Range(.[F1], .Cells(.Rows.Count, 6).End(xlUp))
  11.    If IsDate(A) Then
  12.       If Rng Is Nothing Then
  13.          Set Rng = A
  14.          Else
  15.          Set Rng = Union(Rng, A)
  16.       End If
  17.     End If
  18. Next
  19. Set Rng = Union(Rng, .Cells(.Rows.Count, 1).End(xlUp).Offset(2, 5))
  20. For i = 1 To Rng.Areas.Count - 1
  21.    Set myrng = .Range(Rng.Areas(i).Offset(-1, -5), Rng.Areas(i + 1).Offset(-2, 9))
  22.    sh = myrng.Cells(2, 7)
  23.    With Sheets.Add
  24.    .Name = sh
  25.    myrng.Copy .[A1]
  26.    For j = 1 To myrng.Rows.Count
  27.       .Rows(j).RowHeight = myrng.Rows(j).RowHeight
  28.    Next
  29.    For k = 1 To myrng.Columns.Count
  30.       .Columns(k).ColumnWidth = myrng.Columns(k).ColumnWidth
  31.    Next
  32.    ActiveWindow.Zoom = p
  33.    End With
  34. Next
  35. End With
  36. Application.DisplayAlerts = True
  37. End Sub
複製代碼
學海無涯_不恥下問

TOP

指定新增工作表位置
With Sheets.Add(after:=Sheets(Sheets.Count))
學海無涯_不恥下問

TOP

回復 5# b9208
  1. Sub Split_Sheet()
  2. Dim Rng As Range, A As Range
  3. Application.DisplayAlerts = False
  4. ar = Array("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun")
  5. With Sheets("WW")
  6. .Select
  7. p = ActiveWindow.Zoom
  8. For Each sht In Sheets
  9. If IsNumeric(Application.Match(sht.Name, ar, 0)) Then sht.Delete
  10. Next
  11. For Each A In .Range(.[F1], .Cells(.Rows.Count, 6).End(xlUp))
  12.    If IsDate(A) Then
  13.       If Rng Is Nothing Then
  14.          Set Rng = A
  15.          Else
  16.          Set Rng = Union(Rng, A)
  17.       End If
  18.     End If
  19. Next
  20. Set Rng = Union(Rng, .Cells(.Rows.Count, 1).End(xlUp).Offset(2, 5))
  21. For i = 1 To Rng.Areas.Count - 1
  22.    Set myrng = .Range(Rng.Areas(i).Offset(-1, -5), Rng.Areas(i + 1).Offset(-2, 9))
  23.    sh = myrng.Cells(2, 7)
  24.    With Sheets.Add(after:=Sheets(Sheets.Count))
  25.    .Name = sh
  26.    myrng.Copy .[A1]
  27.    For j = 1 To myrng.Rows.Count
  28.       .Rows(j).RowHeight = myrng.Rows(j).RowHeight
  29.    Next
  30.    For k = 1 To myrng.Columns.Count
  31.       .Columns(k).ColumnWidth = myrng.Columns(k).ColumnWidth
  32.    Next
  33.    ActiveWindow.Zoom = p
  34.    End With
  35. Next
  36. End With
  37. Application.DisplayAlerts = True
  38. End Sub
複製代碼
學海無涯_不恥下問

TOP

回復 8# b9208
  1. Sub Ex()
  2. Dim Ay()
  3. Dim Sh As Worksheet
  4. For Each Sh In Sheets
  5.    With Sh
  6.    If IsNumeric(Application.Match(.Name, Array("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"), 0)) Then
  7.       For Each A In .Range("O:O").SpecialCells(xlCellTypeConstants)
  8.          If IsNumeric(Application.Match(Left(A, 1), Array("E", "M", "R", "S", "T", "U", "W"), 0)) Then
  9.             ar = Array(Format(.[F2], "yyyy/mm/dd"), .Name, .Cells(A.Row, "E"), .Cells(A.Row, "G"), .Cells(A.Row, "H"), .Cells(A.Row, "I"), .Cells(A.Row, "J"), .Cells(A.Row, "K"), .Cells(A.Row, "M"), .Cells(A.Row, "N"), A)
  10.             ReDim Preserve Ay(s)
  11.             Ay(s) = ar
  12.             s = s + 1
  13.          End If
  14.       Next
  15.     End If
  16.     End With
  17. Next
  18. With Sheets("Qt List")
  19. If s > 0 Then .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(s, 11) = Application.Transpose(Application.Transpose(Ay))
  20. End With
  21. End Sub
複製代碼
學海無涯_不恥下問

TOP

回復 10# b9208


   錄製巨集後去了解各個參數,就會有答案
學海無涯_不恥下問

TOP

        靜思自在 : 我們最大的敵人不是別人.可能是自己。
返回列表 上一主題