Question

我正在尝试创建一个自动创建我们在工作中使用的设置的代码。我已经将所有数据收集在一列中，并且从那里它必须以12列宽的行复制数据，每次遇到值0PBS RC 时，它必须从新行开始。结果现在是： enter image description here

这就是我想要的：

enter image description here

这是我现在的代码：

Sub EMCnaarTaq()

Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Dim rng As Range


Set Sheet1 = ThisWorkbook.Sheets("Mix Overzicht")
Set Sheet2 = ThisWorkbook.Sheets("Taqman Platen")

Set rng = Sheet1.Range("AI2:AI500")


For Each cel In rng

If cel.Value = "0PBS*RC*" Then
    cel.Copy
  '  Worksheets("Taqman Platen").Cells(ActiveCell.Row, 8).Select
  '  ActiveCell.Offset(2, 0).Select
    Range("H" & ActiveCell.Row + 2).Select

    'Worksheets("Taqman Platen").Cells(Offset(2, 0), 8).Select
 '   Sheet2.Cells(Offset(2, 0), ActiveCell.Column).Select
     GoTo Plakken


ElseIf cel.Value >= 1 Then
    cel.Copy

Plakken:

    Dim c
        For Each c In Sheet2.Range("H3:S3,H5:S5,H7:S7,H9:S9,H11:S11,H13:S13")
            If c = "" Then
                c.Select
                c.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False 'Select

               Exit For
            End If


        Next
 Else
 End If

 Next




End Sub

我知道问题是，当满足0pbs RC 的值时，它会转到一个新行，但它会一直返回到我选择的范围内的第一个空白单元格。我已经尝试了很多东西，我觉得我很接近，但我找不到那个解决方案。

问候，

帕特里克

Answer 1

我处理此问题的方法是声明第二个范围作为粘贴数据的目标，每次将其偏移一列

然后当0PBSRC值被命中时，将目标地址更改为下一个空行的开头并从那里继续。

类似

set SourceRng = Range(AI1:AI500)
Set TargetRng = Range(H3)

for cel in Sourcerng
TargetRng = TargetRange.offset(0,1)
if TargetRng.column  = 20 #column S or cel.value = 0PBSRC
TargetRng = Range("H" & TargetRange.row+2)
 #do copy / paste here

next cel

Answer 2

@Chris Sampson这是我现在的代码：

Set Sheet1 = ThisWorkbook.Sheets("Mix Overzicht")
Set Sheet2 = ThisWorkbook.Sheets("Taqman Platen")
Set SourceRng = Sheet1.Range("AI2:AI500")
Set TargetRng = Sheet2.Range("H3")

For Each cel In SourceRng
If cel.Value >= 1 Then
TargetRng = TargetRng.Offset(0, 1)
If TargetRng.Column = 20 Or cel.Value = "0PBS*RC*" Then
TargetRng = Range("H" & TargetRng.Row + 2)
cel.Copy
TargetRng.PasteSpecial
End If
End If
Next cel

Answer 3

我终于得到了它，这就是已经成为的;

Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Dim SourceRng As Range
Dim TargetRng As Range


Set Sheet1 = ThisWorkbook.Sheets("Mix Overzicht")
Set Sheet2 = ThisWorkbook.Sheets("Taqman Platen")
Set SourceRng = Sheet1.Range("AI2:AI500")

Set TargetRng = Sheet2.Range("H1")

For Each cel In SourceRng
If cel.Value = "0PBS*RC*" Then
    Range("H" & ActiveCell.Row + 2).Select
    cel.Copy
    ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False 'Select

    ElseIf cel.Value >= 1 Then
    ActiveCell.Offset(0, 1).Select
        If ActiveCell.Column = 20 Then
        Range("H" & ActiveCell.Row + 2).Select
        Else
        End If
    cel.Copy
    ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False 'Select
End If
Next cel

感谢您的帮助！

在满足值时粘贴到新行

3 个答案: