将数据从一张图纸移动到多张图纸-vba_Vba

将数据从一张图纸移动到多张图纸-vba

vba

将数据从一张图纸移动到多张图纸-vba,vba,Vba,我有一些代码可以根据列中的单元格值创建工作表，然后我有下面的代码可以扫描同一列并将该工作表的整行移动到匹配的工作表名称 Sub CopyRowData() 'Declare variables Dim x As Integer Dim y As Integer Dim i As Integer Dim shSource As Worksheet Dim shTarget1 As Worksheet Dim shTarget2 As Worksheet Dim shTarget3 As Work

我有一些代码可以根据列中的单元格值创建工作表，然后我有下面的代码可以扫描同一列并将该工作表的整行移动到匹配的工作表名称

Sub CopyRowData()

'Declare variables
Dim x As Integer
Dim y As Integer
Dim i As Integer
Dim shSource As Worksheet
Dim shTarget1 As Worksheet
Dim shTarget2 As Worksheet
Dim shTarget3 As Worksheet
Dim shTarget4 As Worksheet
Dim shTarget5 As Worksheet
Dim shTarget6 As Worksheet

'Assign string values to variables
Set shSource = ThisWorkbook.Sheets("1")
Set shTarget1 = ThisWorkbook.Sheets("2")
Set shTarget2 = ThisWorkbook.Sheets("3")
Set shTarget3 = ThisWorkbook.Sheets("4")
Set shTarget4 = ThisWorkbook.Sheets("5")
Set shTarget5 = ThisWorkbook.Sheets("6")
Set shTarget6 = ThisWorkbook.Sheets("7")

'Locate the rows to be checked
'2
If shTarget1.Cells(3, 6).Value = "" Then
a = 3
Else
a = shTarget1.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If

'3
If shTarget2.Cells(3, 6).Value = "" Then
b = 3
Else
b = shTarget2.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If

'4
If shTarget3.Cells(3, 6).Value = "" Then
c = 3
Else
c = shTarget3.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If

'5
If shTarget4.Cells(3, 6).Value = "" Then
d = 3
Else
d = shTarget4.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If

'6
If shTarget5.Cells(3, 6).Value = "" Then
e = 3
Else
e = shTarget5.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If

'7
If shTarget6.Cells(3, 6).Value = "" Then
f = 3
Else
f = shTarget6.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If


i = 3

'Do while that will read the data of the cells in the 5th column and if it is match for the string variables, it will move the entire row to the worksheet of the same name
Do While i <= 200
    '2
    If Cells(i, 6).Value = "2" Then
    shSource.Rows(i).Copy
    shTarget1.Cells(a, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    a = a + 1
    GoTo Line1

    '3
    ElseIf Cells(i, 6).Value = "3" Then
    shSource.Rows(i).Copy
    shTarget2.Cells(b, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    b = b + 1
    GoTo Line1
    End If

    '4
    If Cells(i, 6).Value = "4" Then
    shSource.Rows(i).Copy
    shTarget3.Cells(c, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    c = c + 1
    GoTo Line1

    '5
    ElseIf Cells(i, 6).Value = "5" Then
    shSource.Rows(i).Copy
    shTarget4.Cells(d, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    d = d + 1
    GoTo Line1
    End If

    '6
    If Cells(i, 6).Value = "6" Then
    shSource.Rows(i).Copy
    shTarget5.Cells(e, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    e = e + 1
    GoTo Line1

    '7
    ElseIf Cells(i, 6).Value = "7" Then
    shSource.Rows(i).Copy
    shTarget6.Cells(f, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    f = f + 1
    GoTo Line1
    End If

    i = i + 1


Line1:     Loop

    Set mysheet = ActiveSheet
    Dim wrksht As Worksheet
    For Each wrksht In Worksheets

    wrksht.Select
    Cells.EntireColumn.AutoFit

    Next wrksht
    mysheet.Select

End Sub

我没有必要保留原始工作表的数据，因为这不是源工作表

第一张图纸上的数据通过宏的方式来自其源，因此，如果我需要参考源数据，那么这将不会是一个问题

另外，另一个原因是，当我的宏运行时，每个工作表都将作为单独的工作簿保存在一个文件夹中，以便我可以将每个工作表发送到各自的部门。

至于您的明确问题，如果存在sheet.name4，则可以使用此帮助程序功能：

Function IsSheetThere(shtName As String, sht As Worksheet) As Boolean
    On Error Resume Next
    Set sht = Worksheets(shtName)
    IsSheetThere = Not sht Is Nothing
End Function

要像这样使用：

Dim targetSht As Worksheet
If IsSheetThere("4", targetSht) Then
    ... (code to handle existing sheet)
End If

而对于更一般的请求动态代码段，您可以使用rangeobject方法过滤源工作表列F，然后一次性将值复制/粘贴到适当的目标工作表

我假设：

1是一个工作表，您希望在其第6列单元格中从第3行循环到最后一行，并将整行复制/粘贴到名称与当前单元格值匹配的目标工作表

源工作表第6列第2行有一个标题

Sub CopyRowData()
Dim sourceSht  As Worksheet
Set sourceSht = ThisWorkbook.Sheets("1")

Dim iSht As Long
Dim targetSht As Worksheet
With sourceSht
    With .Range("F2", .Cells(.Rows.Count, "F").End(xlUp))
        For iSht = 2 To 7
            If IsSheetThere(CStr(iSht), targetSht) Then
                .AutoFilter Field:=1, Criteria1:=iSht
                If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then
                    Intersect(.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow, .Parent.UsedRange).Copy
                    With targetSht
                        .Cells(WorksheetFunction.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row), 1).PasteSpecial Paste:=xlPasteValues
                        .Cells.EntireColumn.AutoFit
                    End With
                    Application.CutCopyMode = False
                End If
            End If
        Next
    End With
    .AutoFilterMode = False
End With
End Sub

我会这样做的。如果F列中的值是有效的图纸名称，则应为OK

Sub CopyData()

    Dim shtSrc As Worksheet
    Dim c As Range, ws, r As Long, v

    Set shtSrc = ThisWorkbook.Sheets("Sheet1")

    For Each c In shtSrc.Range(shtSrc.Cells(2, 6), shtSrc.Cells(Rows.Count, 6).End(xlUp)).Cells
        v = c.Value
        If Len(v) > 0 Then
            With GetSheet(ThisWorkbook, v)
                'first row with no value in ColF
                r = .Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Row
                If r < 3 Then r = 3     'start at 3rd row
                .Rows(r).Value = c.EntireRow.Value 'copy row content (value only)
            End With
        End If
    Next c

End Sub


'Return a worksheet from a workbook: if not there, create a new sheet
'  with the supplied name and return that
Function GetSheet(wb As Workbook, theName) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = wb.Worksheets(theName)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
        ws.Name = theName
    End If
    Set GetSheet = ws
End Function

谢谢你的回答！我会尝试一下，让你知道事情的进展。我真的更热衷于AutoFilter，因为它的编程实践更好，所以谢谢！我使用了AutoFilter的代码和函数，并执行了代码，但什么也没发生。我在函数的下一步注释掉了错误恢复，得到了错误范围的下标。有什么建议@DisplayName？没有实际的数据视图很难说。您可能希望通过按F8键并在即时窗口中检查相关变量值来逐行调试，以查看发生了什么。

Sub CopyData()

    Dim shtSrc As Worksheet
    Dim c As Range, ws, r As Long, v

    Set shtSrc = ThisWorkbook.Sheets("Sheet1")

    For Each c In shtSrc.Range(shtSrc.Cells(2, 6), shtSrc.Cells(Rows.Count, 6).End(xlUp)).Cells
        v = c.Value
        If Len(v) > 0 Then
            With GetSheet(ThisWorkbook, v)
                'first row with no value in ColF
                r = .Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Row
                If r < 3 Then r = 3     'start at 3rd row
                .Rows(r).Value = c.EntireRow.Value 'copy row content (value only)
            End With
        End If
    Next c

End Sub


'Return a worksheet from a workbook: if not there, create a new sheet
'  with the supplied name and return that
Function GetSheet(wb As Workbook, theName) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = wb.Worksheets(theName)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
        ws.Name = theName
    End If
    Set GetSheet = ws
End Function