我有一个代码
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
如果您的目的是合并来自不同工作表或范围的数据，那么为了显着简化您的代码，同时使其更加健壮(对于行插入之类的东西(，我建议使用Ctrl+T键盘快捷键将每个源范围制作到 Excel 表中，然后使用以下方法之一：
-
使用VBA将单独表中的所有数据合并到一个表中。请参阅 https://stackoverflow.com/a/47279374/2507160
-
使用 PowerQuery 来执行相同的操作。见 https://stackoverflow.com/a/47170312/2507160