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的话,马上结帖给分!!!
[解决办法]
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
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