数据移动不遵循VBA脚本

huangapple go评论68阅读模式
英文:

Data moving not following vba script

问题

这是我在脚本中寻找的内容:

获取分布在不同工作表上的原始数据表的信息,如果列J中的值与工作表的名称匹配。如果列J中的值与工作表名称匹配,则将行剪切到该工作表的第一个可用行(每个工作表将包含多行)。如果没有找到完全匹配,则不要移动原始数据工作表中的数据(应保留在原始数据文件中)。

此外,它应该基于列B中的值(这是唯一的数字)检查重复项。如果该数字已经存在于移动到的工作表中,那么跳过该行。在这种情况下,可以从原始数据中删除该行。

问题是什么:如果它在列J中找到一个值,但无法匹配它,它仍然会将其放入一个工作表(因此一个具有不匹配名称的工作表)截图(见列J)。看不出问题在哪里?

Sub DistributeData()
    ' ...(其他代码部分已省略)

    Set rawDataSheet = ThisWorkbook.Worksheets("RawData") ' 用您原始数据表的名称替换"RawData"

    With rawDataSheet
        ' ...(其他代码部分已省略)

        For i = 2 to lastRow Step 1 ' 遍历行
            valueToMatch = .Cells(i, "J").Value
            uniqueNumber = .Cells(i, "B").Value
            duplicateFound = False

            On Error Resume Next
            Set targetSheet = ThisWorkbook.Worksheets(valueToMatch)
            On Error GoTo 0

            If Not targetSheet Is Nothing Then ' 如果找到匹配的工作表
                For targetRow = 2 To targetSheet.Cells(targetSheet.Rows.Count, "J").End(xlUp).Row
                    If targetSheet.Cells(targetRow, "B").Value = uniqueNumber Then
                        duplicateFound = True
                        Exit For
                    End If
                Next targetRow

                If Not duplicateFound Then
                    ' 剪切行到目标工作表
                    .Rows(i).Copy
                    targetSheet.Cells(targetSheet.Cells(targetSheet.Rows.Count, "J").End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues
                    .Rows(i).Delete
                Else
                    ' 从原始数据表中删除行
                    .Rows(i).Delete
                End If
            End If
        Next i

        ' 设置列E的格式为通用格式以用于数字
        .UsedRange.Columns("E").NumberFormat = "General"
        ' 重置字体颜色为自动
        .UsedRange.Font.ColorIndex = xlAutomatic
        ' 重置背景颜色为无
        .UsedRange.Interior.ColorIndex = xlNone
    End With

    ' 启用屏幕更新
    Application.ScreenUpdating = True
    ' 启用自动计算
    Application.Calculation = xlCalculationAutomatic
End Sub
On Error Resume Next
Set targetSheet = ThisWorkbook.Worksheets(valueToMatch)
On Error GoTo 0

这段代码的目的是尝试设置targetSheet为工作簿中名为valueToMatch的工作表。如果找不到具有该名称的工作表,则targetSheet将保持Nothing。这段代码是正确的,它在没有找到匹配的工作表时不会移动行。如果找不到匹配的工作表,targetSheet将保持Nothing,然后跳到下一步执行。

希望这有助于解决您的问题。如果您有其他问题,请随时提出。

英文:

This is what I am looking for in the script

Get the information of the raw data sheet distributed over the different spreadsheets if value in column J matches name of the spreadsheet. If value in column J matches the spreadsheet name the row can be cut to that spreadsheet in the first available row (several rows will end up in each spreadsheet). Dont move the data from raw data spreadsheet if no exact match is found (should stay in raw data file)

Furthermore it should check for duplicates based on value in column B (is a unique number. If that number already exist in the spreadsheet where it is moved to than skip that line. The line can be deleted from raw data without cutting in that case.

What is the problem: If it finds a value in column J in cannot match it still puts in in a spreadsheet (so a spreadsheet with a not matching name) printscreen (see columnJ). Cannot see what is wrong?

Sub DistributeData()
    Dim rawDataSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim valueToMatch As String
    Dim uniqueNumber As String
    Dim targetRow As Long
    Dim duplicateFound As Boolean

    Application.ScreenUpdating = False ' Disable screen updating for better performance
    Application.Calculation = xlCalculationManual ' Disable automatic calculations

    Set rawDataSheet = ThisWorkbook.Worksheets("RawData") ' Replace "RawData" with the name of your raw data sheet

    With rawDataSheet
        lastRow = .Cells(.Rows.Count, "J").End(xlUp).Row

        For i = 2 to lastRow Step 1 ' Loop through the rows
            valueToMatch = .Cells(i, "J").Value
            uniqueNumber = .Cells(i, "B").Value
            duplicateFound = False

            On Error Resume Next
            Set targetSheet = ThisWorkbook.Worksheets(valueToMatch)
            On Error GoTo 0

            If Not targetSheet Is Nothing Then ' If a matching sheet is found
                For targetRow = 2 To targetSheet.Cells(targetSheet.Rows.Count, "J").End(xlUp).Row
                    If targetSheet.Cells(targetRow, "B").Value = uniqueNumber Then
                        duplicateFound = True
                        Exit For
                    End If
                Next targetRow

                If Not duplicateFound Then
                    ' Cut the row to the target sheet
                    .Rows(i).Copy
                    targetSheet.Cells(targetSheet.Cells(targetSheet.Rows.Count, "J").End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues
                    .Rows(i).Delete
                Else
                    ' Delete the row from the raw data sheet
                    .Rows(i).Delete
                End If
            End If
        Next i

        .UsedRange.Columns("E").NumberFormat = "General" ' Set column E format to General for numbers
        .UsedRange.Font.ColorIndex = xlAutomatic ' Reset font color to automatic
        .UsedRange.Interior.ColorIndex = xlNone ' Reset background color to none
    End With

    Application.ScreenUpdating = True ' Enable screen updating
    Application.Calculation = xlCalculationAutomatic ' Enable automatic calculations
End Sub
 On Error Resume Next
            Set targetSheet = ThisWorkbook.Worksheets(valueToMatch)
            On Error GoTo 0

Is this coding incorrect and does it still move the line? I dont know what else to pu

Thank you in advance

答案1

得分: 1

以下是翻译好的部分:

原因相当简单。您使用以下代码段的想法:

On Error Resume Next
Set targetSheet = ThisWorkbook.Worksheets(valueToMatch)
On Error GoTo 0

还可以。但是,如果没有工作表ThisWorkbook.Worksheets(valueToMatch)(因此该语句会生成一个被忽略的运行时错误),则变量targetSheet不会被修改,它将保持其值。

如果变量在之前没有使用过,它仍然会是Nothing,但是,如果它已经保存了对先前迭代中的工作表的引用,它将保留此引用,以下代码将复制行到上一个工作表。

您只需在每次迭代中初始化变量:

On Error Resume Next
Set targetSheet = Nothing
Set targetSheet = ThisWorkbook.Worksheets(valueToMatch)
On Error GoTo 0

编辑:没有看到您正在删除行。当然,正如评论中的freeflowDavesExcel所指出的那样:您需要反向循环。

For i = lastRow to 2 Step -1 ' 反向遍历行

如果这不可行(因为它会以相反的顺序在目标工作表中添加行),则进行两次循环。在第一次循环中(从2lastRow),复制数据并标记所有要删除的行(例如,在A列中写入“DELETE”)。然后在第二次循环中(从lastRow2 step -1),删除这些行。

英文:

The reason is rather simple. Your idea of using the following snippet

On Error Resume Next 
Set targetSheet = ThisWorkbook.Worksheets(valueToMatch) 
On Error GoTo 0

is okay. However, if there is no sheet ThisWorkbook.Worksheets(valueToMatch) (so the statement produces a runtime error that is ignored), the variable targetSheet is not modified, it keeps its value.

If the variable was not used before, it will still be Nothing, however, if it was already holding a reference to a sheet from an earlier iteration, it will keep this reference and the following code will copy the row to the previous sheet.

All you have to do is to initialize the variable at every iteration:

On Error Resume Next 
Set targetSheet = Nothing
Set targetSheet = ThisWorkbook.Worksheets(valueToMatch) 
On Error GoTo 0

Edit: Didn't saw that you are deleting rows. Of course freeflow and DavesExcel are right in the comments: You need to loop backwards.

For i = lastRow to 2 Step -1   ' Loop backwards through the rows

If this is not okay (because it would add rows in the destination sheets in reverted order), loop twice. In the first loop (from 2 to lastRow), copy the data and mark all rows that are to be deleted (eg by writing "DELETE" in col A). Then in the second loop (from lastRow to 2 step -1), delete those rows.

huangapple
  • 本文由 发表于 2023年6月5日 23:03:43
  • 转载请务必保留本文链接:https://go.coder-hub.com/76407747.html
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定