Question

我有一个密码

1）在工作表1中找到标题

2）在工作表2中找到标题

3）匹配工作表之间的标题并复制并粘贴工作表1到2中类似标题的数据。

4）如果工作表1中的标题存在于“映射”工作表中，则可以选择将标题更改为映射中的标题，然后进行复制和粘贴。

我第一次在工作表1和工作表2之间进行此操作时效果很好（尽管我的工作表1不需要“映射”选项卡）。当我直接在另一张纸上再次尝试此代码时（确实使用了“映射”选项卡），当不应该仅复制标题下的数据时，会复制一些标题。

+------+------------+------+--+
| Col1 |    Col2    | Col3 |  |
+------+------------+------+--+
| Col1 | normaldata | Col3 |  |
|      | normaldata |      |  |
|      | normaldata |      |  |
+------+------------+------+--+

代码：

Option Explicit
Sub importtodatabase(from_ws, to_ws)
    Dim rng As Range, trgtCell As Range
    Dim src As Worksheet
    Dim trgt As Worksheet
    Set src = Worksheets(from_ws)
    Set trgt = Worksheets(to_ws)
    Dim row_num As Integer
    Dim Max_row_data As Integer
    Dim source_tab As String
    Application.ScreenUpdating = False

    Sheets(to_ws).Select
    Max_row_data = get_max_row("")

    If Max_row_data <> 2 Then
        Max_row_data = Max_row_data + 1
    End If

    Sheets("Mappings").Select
    max_row = get_max_row("")


    With src
        For Each rng In Intersect(.Rows(1), .UsedRange).SpecialCells(xlCellTypeConstants)
            For row_num = 2 To max_row
                If from_ws = Range("BU" & row_num).value Then
                    If rng = Range("BV" & row_num).value Then
                        rng = Range("BW" & row_num).value
                        Exit For
                    End If
                End If
            Next row_num

            Set trgtCell = trgt.Rows(1).Find(rng.value, LookIn:=xlValues, lookat:=xlWhole)



                If Not trgtCell Is Nothing Then
                    .Range(rng.Offset(1), .Cells(.Rows.count, rng.Column).End(xlUp)).copy
                    With trgt
                        .Cells(Max_row_data, trgtCell.Column).PasteSpecial xlPasteValues
                    End With
                End If
            'End If
        Next rng
    End With
    Application.ScreenUpdating = False
End Sub

获取最大行功能：

Public Function get_max_row(tab_name, Optional col_srch, Optional include_shapes As Boolean = True, Optional include_border = False)

    Dim max_shape_row As Long: max_shape_row = 0
    Dim max_shape_loc As Double: max_shape_loc = 0

    If IsMissing(col_srch) Then
        col_srch = ""
    End If

    old_tab = ActiveSheet.Name

    If tab_name = "" Then
        tab_name = old_tab
    End If
    select_tab = tab_name

    Sheets(select_tab).Select

    On Error GoTo errorHandler
    max_row_num1 = Sheets(select_tab).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
    On Error GoTo 0

    'max_row_num2 = ActiveSheet.UsedRange.Rows.Count
    max_row_num2 = 2

    'QuickMessage (max_row_num1 & "-" & max_row_num2)

    If max_row_num1 > max_row_num2 Then
        get_max_row = max_row_num1
    Else
        get_max_row = max_row_num2
    End If

    If col_srch <> "" Then
        ref_srch_row = get_max_row

        Do While ref_srch_row > 1
            If Range(col_srch & ref_srch_row).value <> "" Then
                Exit Do
            End If
            ref_srch_row = ref_srch_row - 1
        Loop

        get_max_row = ref_srch_row
    End If

    If include_shapes = True Then
        max_text_row = get_max_row

        shapes_num = IsEmpty(Sheets(tab_name).Shapes)

        If shapes_num = False Then
            For Each Item In Sheets(tab_name).Shapes
                'Debug.Print Item.Name & ":" & Item.Top & ":" & Item.Height

                curr_shape_loc = Item.Top + Item.Height

                max_shape_loc = IIf(curr_shape_loc > max_shape_loc, curr_shape_loc, max_shape_loc)
            Next Item

            For Each cell In Sheets(tab_name).Columns("A:A").Cells
                curr_cell_loc = cell.Top

                If curr_cell_loc > max_shape_loc Then
                    max_shape_row = cell.row
                    Exit For
                End If
            Next cell

            get_max_row = IIf(max_shape_row > max_text_row, max_shape_row, max_text_row)
        End If
    End If

    'check border
    If include_border = True Then
        On Error Resume Next
        count_num = 0
        For Each cell In ActiveSheet.UsedRange.Cells
            count_num = count_num + 1
            If cell.Borders(xlEdgeBottom).LineStyle <> xlNone Then
                get_max_row = Application.Max(max_shape_row, max_text_row, cell.row)
            End If

            If count_num > 10000 Then
                Exit For
            End If
        Next cell
        On Error GoTo 0
    End If

    Sheets(old_tab).Select

    Exit Function

errorHandler:
    get_max_row = 1
    Resume Next
End Function

Answer 1

如果您打算合并来自不同工作表或范围的数据，则为了显着简化代码并同时使其更加健壮（对于行插入之类的东西），我建议您将每个源使用 Ctrl + T 键盘快捷键，然后使用以下方法之一将其放入Excel表：

使用VBA将所有数据从单独的表混搭到一个表中。参见https://stackoverflow.com/a/47279374/2507160
使用PowerQuery进行相同的操作。参见https://stackoverflow.com/a/47170312/2507160

VBA，将工作表复制并粘贴到工作表，复制不需要的标题

1 个答案: