Question

我的任务是从Excel表格中提取奇怪/格式不正确的数据。手动复制的数据太多，所以我尝试使用宏。我不是很熟悉VBA，但我知道一点（可能只是打破了一些东西:)）。

我现在只处理1张纸，但有几张纸，所有纸张都以相同的方式格式化。以下是源数据的代码：我突出显示了我需要复制的细胞。其余数据并不重要，无需提取。

https://ask.fedoraproject.org/en/question/53409/does-fedora-has-composer-in-the-repo/?answer=53445#post-id-53445

正如您所看到的，至少可以说源数据没有格式化为传统的行和列。

我将这些数据复制到我在新工作表中设置的表格中。

****编辑：****我更新了我的代码。我意识到数据被格式化为我需要的数据行之间有相同数量的空格，确切地说是14。我现在有一个Do While循环，每次将行索引增加14以移动到下一条记录。

此代码有效，但我是否正确的方式???我将需要重复此过程约50张，其中一些有1000或更多记录。

Sub CopyData()

Dim SourceSheet As Worksheet
Dim DestSheet As Worksheet
Dim DestRow As Long
Dim i As Integer
i = 0

Set SourceSheet = Sheets("Sheet1")
Set DestSheet = Sheets("Data")

Do While i < 100
    DestRow = DestSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
    SourceSheet.Cells(2 + i, 1).Copy
    DestSheet.Range("A" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    SourceSheet.Cells(2 + i, 2).Copy
    DestSheet.Range("D" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    SourceSheet.Cells(3 + i, 2).Copy
    DestSheet.Range("E" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    SourceSheet.Cells(4 + i, 2).Copy
    DestSheet.Range("F" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    SourceSheet.Cells(2 + i, 7).Copy
    DestSheet.Range("C" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    SourceSheet.Cells(5 + i, 7).Copy
    DestSheet.Range("G" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    SourceSheet.Cells(14 + i, 2).Copy
    DestSheet.Range("B" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    i = i + 14
Loop

End Sub

Answer 1

是的，我认为你所做的很好。你已经弄清楚了这种模式以及如何增加模式。您可能希望在到达工作表末尾时添加某种检查 - 最简单的方法是在for x,y in alist: if x == "Me" and y: if flag: tempcount += 1 initiated = True else: tempcount = 1 flag = True if x == "Me" and not y and flag and initiated: tempcount += 1 if x == "Partner" and y and flag and initiated: permcount.append(tempcount) flag = False if x == "Partner" and not y and flag and initiated: permcount.append(tempcount) flag = False后的第一行测试空白并使用{退出该循环{1}}会让你进入像Do这样的外圈。

这不是我所知道的非常技术性的答案，但似乎你非常接近我并不想在评论中输入所有这些。

Answer 2

我发布了几乎最终代码，我在这里提出以防将来可以帮助任何人。事实证明，一旦我发现数据中的间距相等，就不会像我想象的那么难。感谢@Doug Glancy提供有关使用Exit Do的建议。

我相信这远不是一个完美的解决方案。需要添加一些错误处理/检查。对于可以改进代码的方法或者实现此目的的不同方法，我将不胜感激。

Sub CopyData()

Dim DestSheet As Worksheet
Dim DestRow As Long
Dim i As Integer


Set DestSheet = Sheets("Data")

'Loop through all worksheets in the workbook
For Each Worksheet In ActiveWorkbook.Worksheets

'Reset counter variable for each worksheet
i = 0

    'Check to make sure we are not on the destination sheet
    If Worksheet.Name <> DestSheet.Name Then

        'Loop through all rows in the sheet
        Do While i < Worksheet.Rows.Count

            'Check the contents of the first row in the record to ensure that it contains data
            If Worksheet.Cells(2 + i, 1) <> "" Then

                'Find the next empty row in the destination sheet to copy to
                DestRow = DestSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1

                'Copy and paste data, using paste special because of the formatting and formulas in the source
                Worksheet.Cells(2 + i, 1).Copy
                DestSheet.Range("A" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                Application.CutCopyMode = False

                Worksheet.Cells(2 + i, 2).Copy
                DestSheet.Range("D" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                Application.CutCopyMode = False

                Worksheet.Cells(3 + i, 2).Copy
                DestSheet.Range("E" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                Application.CutCopyMode = False

                Worksheet.Cells(4 + i, 2).Copy
                DestSheet.Range("F" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                Application.CutCopyMode = False

                Worksheet.Cells(2 + i, 7).Copy
                DestSheet.Range("C" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                Application.CutCopyMode = False

                Worksheet.Cells(5 + i, 7).Copy
                DestSheet.Range("G" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                Application.CutCopyMode = False

                Worksheet.Cells(14 + i, 2).Copy
                DestSheet.Range("B" & DestRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                Application.CutCopyMode = False

                'Add 14 to counter, since the rows are equally spaced by 14
                i = i + 14

            Else

            'If the first row contains no data, then exit the loop
                Exit Do

            End If
        Loop

    End If

Next

End Sub

Excel宏将格式不佳的数据复制到表中

2 个答案: