Question

所以我对VBA编码很新，而且我正在尝试设置一个命令按钮，当激活复制时，所有内容从工作表“Opties”到D“和”列中的“BOM”表，其中列为1标题“Totaal”并删除空白。

到目前为止，这是我的代码

Sub Copy()
Dim c As Integer
Dim x As Integer
Dim y As Integer
Dim ws1 As Worksheet: Set ws1 = Sheets("Optie")
Dim ws2 As Worksheet: Set ws2 = Sheets("BOM")
Dim colNum As Integer

colNum = Worksheetfuntion.Match("Totaal", ws1.Range("A1:ZZ1"), 0)
c = 1
x = -4 + colNum
y = -6 + colNum
Set rng1 = ws1.Column(colNum)
Set rng2 = ws2.Range("C5:C25000")

For Each c In ws1.rng1

rng1.Offset(0, x).Copy
rng2.Offset(0, 1).PasteSpecial xlPasteValues
rng1.Offset(0, y).Copy
rng2.Offset(0, 2).PasteSpecial xlPasteValues


Next c
End Sub

Answer 1

我认为以下代码应该有效：

'Try to avoid using names that Excel uses - you will sometimes "block" the
'native function, so call the subroutine "myCopy" or something else, but
'preferably not "Copy"
Sub myCopy()
    Dim r1 As Long ' Use Long rather than Integer, because Excel
    Dim r2 As Long ' now allows for more than 65536 rows
    'Use Worksheets collection for worksheets, and only use the Sheets
    ' collection if you need to process Charts as well as Worksheets
    Dim ws1 As Worksheet: Set ws1 = Worksheets("Optie") 'Should this be "Opties"?
    Dim ws2 As Worksheet: Set ws2 = Worksheets("BOM")
    Dim colNum As Long

    colNum = WorksheetFunction.Match("Totaal", ws1.Range("A1:ZZ1"), 0)
    r2 = 5 ' I guessed that 5 is the first row you want to write to

    'Loop through every row until the last non-empty row in Totaal column
    For r1 = 1 To ws1.Cells(ws1.Rows.Count, colNum).End(xlUp).Row
        'See if value in Totaal column is 1
        If ws1.Cells(r1, colNum).Value = 1 Then
            'I have guessed that your destination columns are D & E based on 
            'your Offset(0, 1) and Offset(0, 2) from column C
            'I have guessed that your source columns are F & D based on the
            'question mentioning those columns, and the offsets of -4 and -6
            'in your current code - I assume based on "Totaal" being column J
            'Change my guesses as necessary

            'Copy values to destination from source
            ws2.Cells(r2, "D").Value = ws1.Cells(r1, "F").Value
            ws2.Cells(r2, "E").Value = ws1.Cells(r1, "D").Value
            'Increment row counter for destination sheet
            r2 = r2 + 1
        End If
    Next
End Sub

基于单元格值代码无效的Excel vba复制和粘贴

1 个答案: