VBA提取excel中的一些特定数据 并复制到同个文件的工作表（Sheet）中

例如 有这样子的excel表格

就是想 做一个按钮
这个按钮的功能是
点击一下，就可以分析FREQUENCY这一列
把属于周一（Mon）的那一行数据的Parameters 数据抽出来，放到别的名字叫Mon的sheet去，当然这些sheet已经存在了
把属于周二（Tue）的那一行数据的Parameters 数据抽出来，放到别的名字叫Tue的sheet去，当然这些sheet已经存在了
・・・・・・・
・・・・・・・


例如;
对于周一（Mon）
应该把Parameters是 1，4，5，6的这一行的数据 抽出来放到Mon的sheet去

对于周周二（Tue）
应该把Parameters是 1-6 的数据 抽出来放到Tue的sheet去



------------------------------------------------------------------------
[b]Parameters        Runtime User              FREQUENCY
------------------------------------------------------------------------
1                           NCSADSM1                   Mon-Sun    
2                           NCSADSM2                   Tue-Sun    
3                           NCSADSM3                   Tue-Sun    
4                           NCSADSM4                   Mon-Sun    
5                           NCSADSM5                   Mon-Sun    
6                           NCSADSM6                   Mon-Fri  
--------------------------------------------------------------------------


在线等啊
谢谢了
OK的话，马上结帖给分！！！

3 个解决方案

#1

Sub test()

Dim flag As Boolean
Dim str, cell
'MsgBox Sheets("Mon").[A65535].End(xlUp).Row
For Each cell In Range(Cells(1, 3), Cells(Range("A65535").End(xlUp).Row, 3))
    flag = False
    For Each str In Array("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun")
        
        If cell.Row <> 1 Then
            If cell.Row <> 1 And Not (cell.Value Like "*-*") Then Exit Sub
            If Split(cell.Value, "-")(0) = str Then flag = True
            
            If flag And StrComp(str, "Mon", vbTextCompare) = 0 Then
                'Mon
                Rows(cell.Row).Copy
                With Sheets("Mon").Cells(Sheets("Mon").[A65535].End(xlUp).Row + 1, 1)
                    .PasteSpecial xlPasteColumnWidths
                    .PasteSpecial xlPasteAll
                End With
            End If
            
            If flag And StrComp(str, "Tue", vbTextCompare) = 0 Then
                'Tue
                Rows(cell.Row).Copy
                With Sheets("Tue").Cells(Sheets("Tue").[A65535].End(xlUp).Row + 1, 1)
                    .PasteSpecial xlPasteColumnWidths
                    .PasteSpecial xlPasteAll
                End With
            End If
            
            If Split(cell.Value, "-")(1) = str Then Exit For
        End If
        
    Next
Next
Application.CutCopyMode = False

End Sub

#2

我的这段代码，应该能符合楼主的需求。
没处理表头，这个楼主自己去完善吧。

Private Sub CopyData()
   Const SHEETNAMETAB   As String = "MonTueWedThuFriSatSun"
   Dim objShts(6) As Worksheet
   Dim objShtData As Worksheet
   Dim lRowRec(6) As Long
   Dim iBgnVal&, iEndVal&, t&
   Dim i&, j&, strTemp$
   For i = 1 To Len(SHEETNAMETAB) Step 3
      Set objShts(i \ 3) = Sheets(Mid$(SHEETNAMETAB, i, 3))
   Next
   Set objShtData = Sheets("sheet1")   '原始数据在 Sheet1
   i = 2          ' 数据从第2行开始
   For j = 0 To 6: lRowRec(j) = i - 1: Next
   Do
      strTemp = objShtData.Cells(i, 3)
      If (Len(strTemp) = 0) Then Exit Do
      t = InStr(SHEETNAMETAB, Left$(strTemp, 3))
      If (t = 0) Then
         iBgnVal = -1
      Else
         iBgnVal = t \ 3
      End If
      t = InStr(SHEETNAMETAB, Right$(strTemp, 3))
      If (t = 0) Then
         iEndVal = -1
      Else
         iEndVal = t \ 3
      End If
      If ((iEndVal Or iBgnVal) = -1) Then
         MsgBox "第 " & i & " 行的FREQUENCY数据有误! ", vbExclamation
      Else
         For j = iBgnVal To iEndVal
            t = lRowRec(j) + 1
            lRowRec(j) = t
            objShts(j).Cells(t, 1).Value = objShtData.Cells(i, 1)
            objShts(j).Cells(t, 2).Value = objShtData.Cells(i, 2)
            objShts(j).Cells(t, 3).Value = objShtData.Cells(i, 3)
         Next
      End If
      i = i + 1
   Loop
End Sub

#3

谢谢，结帖给分！~