满足将行复制到sheet2中的值
在Excel VBA中，我是完全的新手
如果满足某些条件，我有一个任务将sheet1中的行复制到2中。
在Sheet1中，列JY中的值以列MV结尾我希望如果您可以帮助我写一个macros来将所有行复制到sheet2，其中包含小于1的值。有可能一行可以有多个<1个值。
例如：第16行可以在jY 0.9以下，MA 0.5以下
最好的结果是在表2中只能看到列A，B，C，D和列值小于1的列，但是如果不可能，那么复制整行就没有问题。
到目前为止，我已经find了一个正在复制正好是1的值的代码
这里是我想改变的代码：
Sub SearchForNumber1() Dim LSearchRow As Integer Dim LCopyToRow As Integer On Error GoTo Err_Execute 'Start search in row 1 LSearchRow = 1 'Start copying data to row 2 in Sheet2 (row counter variable) LCopyToRow = 2 While Len(Range("A" & CStr(LSearchRow)).Value) > 0 'If value in column E = "Mail Box", copy entire row to Sheet2 If Range("B" & CStr(LSearchRow)).Value = "1" Then 'Select row in Sheet1 to copy Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select Selection.Copy 'Paste row into Sheet2 in next row Sheets("Sheet2").Select Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select ActiveSheet.Paste 'Move counter to next row LCopyToRow = LCopyToRow + 1 'Go back to Sheet1 to continue searching Sheets("Sheet1").Select End If LSearchRow = LSearchRow + 1 Wend 'Position on cell A3 Application.CutCopyMode = False Range("A3").Select MsgBox "All matching data has been copied." Exit Sub Err_Execute: MsgBox "An error occurred." End Sub 愿这有助于
Sub moveData() Dim rng As Range Dim iniCol As Range Dim i Dim c Dim myIndex Dim cellVal Dim totalCols Dim sht1 As Worksheet Dim sht2 As Worksheet Set sht1 = Sheets("Sheet1") Set sht2 = Sheets("Sheet2") Set rng = Range("K1:M32") Set iniCol = Range("K1:K32") totalCols = rng.Columns.Count 'Count the total of columns in the selectec range myIndex = 0 'ini the index for rows in sheet2 For Each i In iniCol For c = 1 To totalCols cellVal = i.Offset(0, c - 1).Value If cellVal < 1 Then myIndex = myIndex + 1 Range(Cells(i.Row, 1), Cells(i.Row, 3)).Copy 'Copy range from A to C sht2.Activate Range(Cells(myIndex, 1), Cells(myIndex, 3)).PasteSpecial xlPasteAll 'Paste range equal to copy range. Application.CutCopyMode = False sht1.Activate Exit For End If Next c Next i End Sub
在列A，B，C和K，L，M
HMG BNA ALI -2 6 4 HCM INH KJA 6 5 2 DDN EHJ AKK 1 -7 -6 OLG BMG AJC -7 1 0 CGK PEA EFB 6 5 2 BGO CGI EOO 8 -9 -2 NHB CGP IEJ -2 3 -8 PNK JBN HKJ 6 5 2 ABC JIG NHB 8 8 -10 BBO EIL NDH -1 10 -7 GJE PNK LNL 2 8 10 GMF HIF EFP 6 5 2 AIB EJP NDL -6 -5 8 IKM IIA GDL 6 5 0 PCE KJA HPJ 6 5 2 FFE KFM CPB -5 -1 -10 MHO IJL FCL 6 5 2 EPI PPF IOE -5 2 -5 ANO PAO HHG 6 5 2 MGL GII PEB -3 8 2 PJK OKI GME -3 4 10 AEP NMN JML 6 5 2 ANE KBK NGJ -10 -7 -4 JLJ IIH OLG 6 5 2 PLH HBK PIK -9 6 -3 ICC MEB LKO 6 5 2 MBH OGA JJA 4 9 0 IAN HBK ANJ 6 5 2 FNP FPE KLG 2 2 8 LAI ALE HHP 6 5 2 NLG IFG MDB -10 -8 0 ICE OHG BFH 9 -8 0
结果：
只需导入这些行，仅从A到C（如果您还希望这些值只是增加了复制范围的列）
HMG BNA ALI DDN EHJ AKK OLG BMG AJC BGO CGI EOO NHB CGP IEJ ABC JIG NHB BBO EIL NDH AIB EJP NDL IKM IIA GDL FFE KFM CPB EPI PPF IOE MGL GII PEB PJK OKI GME ANE KBK NGJ PLH HBK PIK MBH OGA JJA NLG IFG MDB ICE OHG BFH
一个价值千言万语的形象 
编辑＃1
以下是您在评论中提出的代码：
Sub moveData() Dim rng As Range Dim iniCol As Range Dim i Dim c Dim myIndex Dim cellVal Dim totalCols Dim sht1 As Worksheet Dim sht2 As Worksheet Dim ABC 'var to store data from Cols A,B,C in Sheet1 Dim KLM 'var to store data from Cols K,L,M in Sheet1 Set sht1 = Sheets("Sheet1") Set sht2 = Sheets("Sheet2") Set rng = Range("K1:M32") Set iniCol = Range("K1:K32") totalCols = rng.Columns.Count 'Count the total of columns in the selectec range myIndex = 0 'ini the index for rows in sheet2 For Each i In iniCol For c = 1 To totalCols cellVal = i.Offset(0, c - 1).Value If cellVal < 1 Then myIndex = myIndex + 1 'Now anything is copied, instead is stored inside this two vars, cols A, B, C and K, L, M as well ABC = Range(Cells(i.Row, 1), Cells(i.Row, 3)) KLM = Range(Cells(i.Row, 11), Cells(i.Row, 13)) ' sht2.Activate Range(Cells(myIndex, 1), Cells(myIndex, 3)).Value = ABC Range(Cells(myIndex, 6), Cells(myIndex, 8)).Value = KLM 'and put it back in sheet2 in cols 1=A to 3=C and 6=F to 8=H ' 'Application.CutCopyMode = False 'Not used anymore. sht1.Activate Exit For End If Next c Next i End Sub
编辑＃2
检查值，如果任何值<1，则只在F列中将值放在一行中，另一个单元格中的下一个值。
Sub moveData() Dim rng As Range Dim iniCol As Range Dim i Dim v Dim x Dim myIndex Dim cellVal Dim totalCols Dim sht1 As Worksheet Dim sht2 As Worksheet Dim ABC() 'var to store data from Cols A,B,C in Sheet1 Dim KLM As Range 'var to store data from Cols K,L,M in Sheet1 Set sht1 = Sheets("Sheet1") Set sht2 = Sheets("Sheet2") Set rng = Range("K1:M32") Set iniCol = Range("K1:K32") totalCols = rng.Columns.Count 'Count the total of columns in the selectec range myIndex = 0 'ini the index for rows in sheet2 For Each i In iniCol x = -1 ABC = Range(Cells(i.Row, 1), Cells(i.Row, 3)) Set KLM = Range(Cells(i.Row, 11), Cells(i.Row, 13)) 'Copy range from A to C sht2.Activate myIndex = Application.WorksheetFunction.CountA(Columns(1)) + 1 For Each v In KLM If v.Value < 1 Then x = x + 1 Range(Cells(myIndex + x, 6), Cells(myIndex + x, 6)).Value = v.Value Range(Cells(myIndex + x, 1), Cells(myIndex + x, 3)).Value = ABC End If Next v 'Paste range equal to copy range. 'Application.CutCopyMode = False sht1.Activate Next i End Sub
这是我的结果：
HMG BNA ALI -2 DDN EHJ AKK -7 DDN EHJ AKK -6 OLG BMG AJC -7 OLG BMG AJC 0 BGO CGI EOO -9 BGO CGI EOO -2 NHB CGP IEJ -2 NHB CGP IEJ -8 ABC JIG NHB -10 BBO EIL NDH -1 BBO EIL NDH -7 AIB EJP NDL -6 AIB EJP NDL -5 IKM IIA GDL 0 FFE KFM CPB -5 FFE KFM CPB -1 FFE KFM CPB -10 EPI PPF IOE -5 EPI PPF IOE -5 MGL GII PEB -3 PJK OKI GME -3 ANE KBK NGJ -10 ANE KBK NGJ -7 ANE KBK NGJ -4 PLH HBK PIK -9 PLH HBK PIK -3 MBH OGA JJA 0 NLG IFG MDB -10 NLG IFG MDB -8 NLG IFG MDB 0 ICE OHG BFH -8 ICE OHG BFH 0
将值收集到一个variables数组中将快速完成运行，以查找有效的值以转到Sheet2。
Sub copy_multi_less_than_one() Dim rw As Long, cl As Long Dim bCOPY As Boolean, v As Long, vVALs As Variant 'Application.ScreenUpdating = False With Worksheets("Sheet1") With .Cells(1, 1).CurrentRegion For rw = 2 To .Rows.Count vVALs = .Cells(rw, 1).Resize(1, 360).Value2 bCOPY = False For v = 5 To UBound(vVALs, 2) If v < 285 Then vVALs(1, v) = vbNullString ElseIf application.sum(vVALs(1, v)) >= 1 Then vVALs(1, v) = vbNullString Else bCOPY = True End If Next v If bCOPY Then With Worksheets("Sheet2") .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(vVALs, 2)) = vVALs End With End If Next rw 'optionally delete the columns from E to JX 'Worksheets("Sheet2").Columns("E:JX").EntireColumn.Delete End With End With Application.ScreenUpdating = True End Sub