把数据复制到标题相同

cmo9020

B.rar (27.81 KB, 下载次数: 9)

2023-2-19 12:49 上传

点击文件名下载附件

各位周未愉快~请问导师们一下....
Sheet6工作表要依据第1行标题和数据.xlsx里面的"数据表"工作表 B3行列的标题做对应,字符串要一模一样在把数据复制过去,需要怎么写

目前有点错乱,请导师们有空帮助一下,谢谢各位~谢谢


Sub CopyDataToAnotherWorkbook()
    Dim destWorkbook As Workbook
    Dim destWorksheet As Worksheet
    Dim srcWorksheet As Worksheet
    Dim destRow As Long
    Dim lastRow As Long
    Dim lastCol As Long
    Dim i As Long, j As Long
    Dim header As String
    Set destWorkbook = Workbooks.Open(ThisWorkbook.path & "\数据.xlsx")
    Set destWorksheet = destWorkbook.Sheets("数据表")
    lastRow = destWorksheet.Cells(Rows.Count, 2).End(xlUp).Row
    lastCol = destWorksheet.Cells(3, Columns.Count).End(xlToLeft).Column

    header = destWorksheet.Cells(3, 2).Value

    Set srcWorksheet = ThisWorkbook.Sheets("Sheet6")

    For i = 2 To lastCol
        If destWorksheet.Cells(3, i).Value = header Then
            For j = 2 To srcWorksheet.Cells(Rows.Count, 1).End(xlUp).Row
                If srcWorksheet.Cells(j, i).Value <> "" Then
                    destRow = lastRow + j - 1
                    destWorksheet.Cells(destRow, 2).Resize(1, lastCol - 1).Value = _
                        srcWorksheet.Cells(j, 2).Resize(1, lastCol - 1).Value
                End If
            Next j
            Exit For
        End If
    Next i

    destWorkbook.Close SaveChanges:=True
End Sub

杨建营

两个表的格式为什么不做成一样的？
自己操作也方便啊。

cmo9020

杨建营 发表于 2023-2-19 15:17
两个表的格式为什么不做成一样的？
自己操作也方便啊。

卡到每个人做的表不见的一样,想直接使用字符串对应把数据套进去比较快

杨建营

cmo9020 发表于 2023-2-19 15:35
卡到每个人做的表不见的一样,想直接使用字符串对应把数据套进去比较快

请楼主参考。

gwjkkkkk

请楼主参考附件。。。

cmo9020

gwjkkkkk 发表于 2023-2-19 17:34
请楼主参考附件。。。

B.rar (29.5 KB, 下载次数: 1)

2023-2-19 19:31 上传

点击文件名下载附件

抱歉,导师我没说很清楚在
SHEET6 不管有多少资料，全部都一起汇入到数据.XLSX数据表工作表里面
麻烦您一下幫忙改一下,谢谢您~

cmo9020

杨建营 发表于 2023-2-19 16:06
请楼主参考。

谢谢您,

gwjkkkkk

cmo9020 发表于 2023-2-19 19:31
抱歉,导师我没说很清楚在
SHEET6 不管有多少资料，全部都一起汇入到数据.XLSX数据表工作表里面
麻烦 ...

数据表中数据添加还是全部更新。。。

gwjkkkkk

Option Explicit
Sub TEST()
    Dim strFileName$, strPath$, dic As Object
    Dim ar, br, i&, j&, r&, vItem
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "数据.xlsx"
    If Dir(strFileName) = "" Then MsgBox "指定的文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    ar = [A1].CurrentRegion
   
    With Workbooks.Open(strFileName)
         With .Sheets(2)
             With .[B3].CurrentRegion
                 .Offset(1).Clear
                 br = .Resize(UBound(ar))
                 For i = 1 To UBound(br, 2): dic(br(1, i)) = i: Next
                 r = 1
             End With
             For i = 2 To UBound(ar)
                 r = r + 1
                 For j = 1 To UBound(ar, 2)
                     vItem = dic(ar(1, j))
                     If vItem <> "" Then
                          br(r, vItem) = ar(i, j)
                     End If
                 Next j
             Next i
             With .[B3].Resize(r, UBound(br, 2))
                 .Value = br
                 .Columns(1).NumberFormatLocal = "m月d日"
                 .HorizontalAlignment = xlCenter
                 .Borders.LineStyle = xlContinuous
                 .EntireColumn.AutoFit
                 .EntireRow.AutoFit
             End With
         End With
         .Close True
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请楼主参考附件。。。