Question

我还是VBA的新手，并且在寻求帮助之前一直在尝试我能想到的一切，但是无法理解。

我有一个包含多个标签的excel文件。我只关心其中的两个。我需要将基于其值不是空白的行从“路线图”选项卡组合到“PPPP”选项卡上的列B中。我的代码将为第一组数据执行此操作，但随后将该数据替换为第二组数据。

Sub Move_PPPP()

Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents

Dim rowCount2 As Long, shtSrc As Worksheet
Dim shtDest As Worksheet
Dim rng2 As Range
Dim currentRow As Long

    Set shtSrc = Sheets("Roadmap")
    Set shtDest = Sheets("PPPP")

    rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row

    Set rng2 = shtSrc.Range("C6:C" & rowCount2)

    currentRow = 2

        For Each cell2 In rng2.Cells
        If cell2.Value <> "" Then

       shtDest.Range("B" & currentRow).Value2 = "           " & cell2.Text & " - " & cell2.Offset(0, 10).Text
       shtDest.Range("B" & currentRow).Value2 = "           " & cell2.Text & " - " & cell2.Offset(0, 11).Text
       shtDest.Range("B" & currentRow).Value2 = "           " & cell2.Text & " - " & cell2.Offset(0, 12).Text
          currentRow = currentRow + 1

        ElseIf cell2.Value = "" Then

        End If
        Next cell2

End Sub

我曾尝试为目标工作表添加范围，但这样做只会从“路线图”标签中提供9行最后一行数据

Sub Move_PPPP()

Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents

Dim rowCount2 As Long, shtSrc As Worksheet
Dim columnCount As Long
Dim shtDest As Worksheet
Dim rng2 As Range
Dim rng As Range
Dim currentRow As Long

    Set shtSrc = Sheets("Roadmap")
    Set shtDest = Sheets("PPPP")

    rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row
    columnCount = shtDest.Cells(Columns.Count, "B").End(xlUp).Row

    Set rng2 = shtSrc.Range("C6:C" & rowCount2)
    Set rng = shtDest.Range("B2:B" & columnCount & currentRow)

    currentRow = 2

        For Each cell2 In rng2.Cells
        If cell2.Value <> "" Then

        rng.Value = "           " & cell2.Text & " - " & cell2.Offset(0, 10).Text

            currentRow = currentRow + 1

        ElseIf cell2.Value = "" Then

        End If
        Next cell2


End Sub

样本数据

路线图标签

栏目：C D E F G H I J K L M 标题：项目状态打开关闭名称P1 P2 P3 P4 P5 P6

第1行：FISMA New是否Albert na na na na新日旧数据第2行：QRD已关闭否是Albert na na na na na已关闭

期望的结果。当M＆lt;＆gt;时，将C列与M列组合。空白，遍历整行并将该数据放入PPPP选项卡的B列。然后当N＆lt; N＆gt;时将C组与N组合。空白并将其放在PPPP选项卡上，将列放在M列的数据下。

PPPP标签

细胞B2 FISMA - 新的一天

细胞B4 FISMA - 旧数据 QRD - 已关闭

解决方案：

Sub Move_PPPP()

Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents

Dim rowCount2 As Long, shtSrc As Worksheet
Dim shtDest As Worksheet
Dim rng2 As Range
Dim currentRow As Long

    Set shtSrc = Sheets("Roadmap")
    Set shtDest = Sheets("PPPP")

    rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row

    Set rng2 = shtSrc.Range("C6:C" & rowCount2)

    currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row

        For Each cell2 In rng2.Cells
        If cell2.Value2 <> "" Then
        shtDest.Range("A" & currentRow).Value2 = "           " & cell2.Text & " - " & cell2.Offset(0, 9).Text
        currentRow = currentRow + 1

        ElseIf cell2.Value = "" Then

        End If
        Next cell2

    Set rng2 = shtSrc.Range("C6:C" & rowCount2)

    currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row + 1

       For Each cell2 In rng2.Cells
       If cell2.Value2 <> ""  Then
       shtDest.Range("A" & currentRow + 1).Value2 = "           " & cell2.Text & " - " & cell2.Offset(0, 10).Text
       currentRow = currentRow + 1

        ElseIf cell2.Value = "" Then

        End If
        Next cell2

    Set rng2 = shtSrc.Range("C6:C" & rowCount2)

    currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row + 1

       For Each cell2 In rng2.Cells
       If cell2.Value2 <> ""  Then
       shtDest.Range("A" & currentRow + 1).Value2 = "           " & cell2.Text & " - " & cell2.Offset(0, 11).Text
       currentRow = currentRow + 1

        ElseIf cell2.Value = "" Then

        End If
        Next cell2

            Set rng2 = shtSrc.Range("C6:C" & rowCount2)

    currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row + 1

       For Each cell2 In rng2.Cells
       If cell2.Value2 <> ""  Then
       shtDest.Range("A" & currentRow + 1).Value2 = "           " & cell2.Text & " - " & cell2.Offset(0, 12).Text
       currentRow = currentRow + 1

        ElseIf cell2.Value = "" Then

        End If
        Next cell2

End Sub

Answer 1

在第一个版本上，试试这个：

 Sub Move_PPPP()

Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents

Dim rowCount2 As Long, shtSrc As Worksheet
Dim shtDest As Worksheet
Dim rng2 As Range
Dim currentRow As Long

    Set shtSrc = Sheets("Roadmap")
    Set shtDest = Sheets("PPPP")

    rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row

    Set rng2 = shtSrc.Range("C6:C" & rowCount2)

    currentRow = shtDest.Range("B" & Rows.Count).End(xlUp).Row

        For Each cell2 In rng2.Cells
        If cell2.Value <> "" Then

       shtDest.Range("B" & currentRow).Value2 = "           " & cell2.Text & " - " & cell2.Offset(0, 10).Text
       shtDest.Range("B" & currentRow + 1).Value2 = "           " & cell2.Text & " - " & cell2.Offset(0, 11).Text
       shtDest.Range("B" & currentRow + 2).Value2 = "           " & cell2.Text & " - " & cell2.Offset(0, 12).Text
          currentRow = currentRow + 1

        ElseIf cell2.Value = "" Then

        End If
        Next cell2

 Set rng2 = shtSrc.Range("D6:D" & rowCount2)

    currentRow = shtDest.Range("B" & Rows.Count).End(xlUp).Row + 1

        For Each cell2 In rng2.Cells
        If cell2.Value <> "" Then

       shtDest.Range("B" & currentRow).Value2 = "           " & cell2.Text & " - " & cell2.Offset(0, 10).Text
       shtDest.Range("B" & currentRow + 1).Value2 = "           " & cell2.Text & " - " & cell2.Offset(0, 11).Text
       shtDest.Range("B" & currentRow + 2).Value2 = "           " & cell2.Text & " - " & cell2.Offset(0, 12).Text
          currentRow = currentRow + 1

        ElseIf cell2.Value = "" Then

        End If
        Next cell2

End Sub

VBA将多列数据合并为一列

1 个答案: