将行复制到sheet2的值范围内-Java 学习之路

对于Excel VBA，我是完全新手

如果满足某些条件，我有一项任务要将行从sheet1复制到sheet 2 .

在sheet1中，列JY中的值以列MV结尾我希望如果你能帮我编写一个宏来将所有行复制到包含小于1的值的sheet2 . 一行可能有多个<1值 .

例如：第16行可以在jY 0.9列和MA 0.5下

最好的结果是在表2中只看到列A，B，C，D和列的值小于1，但如果不可能那么复制整行就没问题了 .

到目前为止，我发现了一个复制正好值为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

2 回答

愿这有用，

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

一张 Value 千言万语的图片
an image worth a thousand words

Edit #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

Edit#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

回复于 2024-05-05T22:46:52+08:00

将值收集到变量数组中将快速运行它们，查找有效值以将其转移到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

回复于 2024-05-05T22:46:52+08:00

将行复制到sheet2的值范围内

2 回答

相关问题