粘贴到另一个单元格和WS，同时循环并向下移动一行 [英] Paste to another cell and WS while looping and shifting down a row

问题描述

我正在寻找一些帮助让这段代码正常运行。我在这里得到了一些伟大人物的第一部分帮助！
基本上，我现在的代码将单元格的格式设置为粗体，因为粗体表示日期。我试图找到列A中的各个段，然后将列D中的相应数字复制到列C中的另一个工作表中。如果在该范围内未找到该值，那么行输出应该向下移动一个而不填充任何内容。
这是我到目前为止：

  Public Sub DataBetween（）
 Dim thisWB As Workbook 
 Dim dataWS As Worksheet 
 Set thisWB = ThisWorkbook 
 Set dataWS = thisWB.sheets（FC01.RPT）
 Set MoBWS = thisWB.sheets（Mix of Business）
 
'---找到第一个粗体单元格... 
 Dim nextBoldCell As range 
 Set nextBoldCell = FindNextBoldInColumn（dataWS.range（A1））
 
'---现在注意数据的开始并找到下一个粗体单元格
 Dim startOfDataRow As Long 
 Dim endOfDataRow As Long 
 Dim lastRowOfAllData As Long 
 startOfDataRow = 3 
'Set lastRowOfAllData = dataWS.Cells（ws.Rows.Count，A）。End（xlUp）.Row 
 
'---该循环适用于所有数据集... 
 Do 
 endOfDataRow = EndRowOfDataSet（dataWS，startOfDataRow）
 
' - 这个循环是通过一个数据集
来处理的对于i = startOfDataRow endOfDataRow 
张（FC01.RPT）。选择
 Cells.Find（What：=Individual return guest）。激活
 
 range（D& （ActiveCell.Row））。选择
 Selection.copy 
 sheets（Plan）。选择
 range（C3）。选择
 ActiveSheet.Paste 
 
 Next i 
 startOfDataRow = endOfDataRow + 1 
 Loop 
 
'Do While endOfDataRow< lastRowOfAllData 
 
 errhandler：
 MsgBox没有找到包含指定文本的单元格
 
 End Sub 
 
 
公共函数FindNextBoldInColumn（ ByRef startCell作为范围，_ 
可选的columnNumber As Long = 1）作为范围
'---从startCell行开始，此函数检查同一列中每个
'的较低行并停止当它遇到
'一个大胆的字体设置
 Dim checkCell As range 
 Set checkCell = startCell 
 Do While Not checkCell.Font.bold 
 Set checkCell = checkCell.Offset （1，0）
如果checkCell.Row = checkCell.Parent.Rows.Count然后
'---我们已经到了列的末尾，所以
'没有返回任何
 Set FindNextBoldInColumn = Nothing 
 Exit Function 
 End If 
 Loop 
 Set FindNextBoldInColumn = checkCell 
 End Function 
 
 
 Pr ivate Function EndRowOfDataSet（ByRef ws As Worksheet，_ 
 ByVal startRow As Long，_ 
可选的maxRowsInDataSet As Long = 50）As Long 
'---检查起始行下面的每一行是一个BOLD单元格
'，或者如果没有检测到BOLD单元格，则返回最后一行数据
 Dim checkCell As range 
 Set checkCell = ws.Cells（startRow，1）'assume column A
 Dim i As Long 
 For i = startRow To maxRowsInDataSet 
 If ws.Cells（startRow，1）.Font.bold Then 
 EndRowOfDataSet = i  -  1 
退出函数
结束如果
下一个我
'---如果我们在这里创建，我们没有找到一个BOLD单元，所以
'找到最后一行数据
 EndRowOfDataSet = ws.Cells（ws.Rows.Count，A）。End（xlUp）.Row 
 
 End Function 
  

代码不断崩溃。我怎么能这样做，所以当循环一个范围时，无论它是否找到值，输出线都会下移一个？

有人知道该怎么做吗？
以下是我正在使用的数据的快照：

感谢您的帮助!!

解决方案

我注意到所有的块 Summe出现在列A中，数据从第14行开始

然后我会这样去做：

<$>

<$> （$code> Sub mm（）
Dim iArea As Long

With Worksheets（FC01.RPT）
With .Range（A14 ，.Cells（.Rows.Count，1）.End（xlUp））
.Cells（2，1）.Value =Summe
.AutoFilter field：= 1，Criteria1：=Summe *
With .Resize（.Rows.Count - 1）.Offset（1）.SpecialCells（xlCellTypeVisible）'.Offset（-1）
For iArea = 1 To .Areas.Count - 1
With .Parent.Range（.Areas（iArea）.Offset（1），.Areas（iArea + 1）.Offset（-1））
Worksheets（Plan）。Cells（Rows.Count，D）。End（xlUp）.Offset（1）.Value = WorksheetFunction.SumIf（.Cells，Individual *，.Offset（， 3））
End With
Next
End With
.Cells（2，1）.ClearContents
End With
.AutoFilterMode = False
End With
End Sub

I am looking for some help in getting this code to run properly. I've gotten some help with the first part from some great people here! Basically, the code I have now sets ranges in between cells formatted bold, as the bold represents a date. I am trying to find the individual segments in column A and copy the coresponding number in column D to another worksheet in column C. If the value is not found in the range, the row output should shift down one without filling in anything. Here is what I have so far:

Public Sub DataBetween()
    Dim thisWB As Workbook
    Dim dataWS As Worksheet
    Set thisWB = ThisWorkbook
    Set dataWS = thisWB.sheets("FC01.RPT")
    Set MoBWS = thisWB.sheets("Mix of Business")

    '--- find the first bold cell...
    Dim nextBoldCell As range
    Set nextBoldCell = FindNextBoldInColumn(dataWS.range("A1"))

    '--- now note the start of the data and find the next bold cell
    Dim startOfDataRow As Long
    Dim endOfDataRow As Long
    Dim lastRowOfAllData As Long
    startOfDataRow = 3
    'Set lastRowOfAllData = dataWS.Cells(ws.Rows.Count, "A").End(xlUp).Row

    '--- this loop is for all the data sets...
    Do
        endOfDataRow = EndRowOfDataSet(dataWS, startOfDataRow)

        '--- this loop is to work through one data set
        For i = startOfDataRow To endOfDataRow
        sheets("FC01.RPT").Select
        Cells.Find(What:="Individual return guest").Activate

        range("D" & (ActiveCell.Row)).Select
        Selection.copy
            sheets("Plan").Select
            range("C3").Select
            ActiveSheet.Paste

        Next i
            startOfDataRow = endOfDataRow + 1
    Loop

    'Do While endOfDataRow < lastRowOfAllData

errhandler:
    MsgBox "No Cells containing specified text found"

End Sub


Public Function FindNextBoldInColumn(ByRef startCell As range, _
                                     Optional columnNumber As Long = 1) As range
    '--- beginning at the startCell row, this function check each
    '    lower row in the same column and stops when it encounters
    '    a BOLD font setting
    Dim checkCell As range
    Set checkCell = startCell
    Do While Not checkCell.Font.bold
        Set checkCell = checkCell.Offset(1, 0)
        If checkCell.Row = checkCell.Parent.Rows.Count Then
            '--- we've reached the end of the column, so
            '    return nothing
            Set FindNextBoldInColumn = Nothing
            Exit Function
        End If
    Loop
    Set FindNextBoldInColumn = checkCell
End Function


Private Function EndRowOfDataSet(ByRef ws As Worksheet, _
                                 ByVal startRow As Long, _
                                 Optional maxRowsInDataSet As Long = 50) As Long
    '--- checks each row below the starting row for either a BOLD cell
    '    or, if no BOLD cells are detected, returns the last row of data
    Dim checkCell As range
    Set checkCell = ws.Cells(startRow, 1)  'assumes column "A"
    Dim i As Long
    For i = startRow To maxRowsInDataSet
        If ws.Cells(startRow, 1).Font.bold Then
            EndRowOfDataSet = i - 1
            Exit Function
        End If
    Next i
    '--- if we make it here, we haven't found a BOLD cell, so
    '    find the last row of data
    EndRowOfDataSet = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

End Function

The code keeps crashing. How can I make it so the output line shifts down one when looping though a range, no matter if it finds the value or not?

Does anyone know what do to? Here is a snapshot of the data I am working with:

Thanks for the help!!

解决方案

I noticed all your "blocks" end with some "Summe" occurrence in column A, and data begins at row 14

then I'd go this way:

Sub mm()
    Dim iArea As Long

    With Worksheets("FC01.RPT")
        With .Range("A14", .Cells(.Rows.Count, 1).End(xlUp))
            .Cells(2, 1).Value = "Summe"
            .AutoFilter field:=1, Criteria1:="Summe*"
            With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) '.Offset(-1)
                For iArea = 1 To .Areas.Count - 1
                    With .Parent.Range(.Areas(iArea).Offset(1), .Areas(iArea + 1).Offset(-1))
                        Worksheets("Plan").Cells(Rows.Count, "D").End(xlUp).Offset(1).Value = WorksheetFunction.SumIf(.Cells, "Individual*", .Offset(, 3))
                    End With
                Next
            End With
            .Cells(2, 1).ClearContents
        End With
        .AutoFilterMode = False
    End With
End Sub

这篇关于粘贴到另一个单元格和WS，同时循环并向下移动一行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！