根据组织人事部的excel文件粘贴对应项目的数据

shiruiqiang

这句改为：
if len(arr(i,1) &arr(i,2)&arr(i,3)&arr(i,4))<>0 then

andy117

shiruiqiang 发表于 2024-11-7 15:49
这句改为：
if len(arr(i,1) &arr(i,2)&arr(i,3)&arr(i,4))0 then

改成arr(i,2)即可，谢谢帮助

andy117

ykcbf1100 发表于 2024-11-7 15:09
参与一下。。。

1. End With
   
2.     End With
   
3.     For k = 2 To 10000
   
4.     Sheet1.Cells(k, 1) = Application.WorksheetFunction.Text(Sheet1.Cells(k, 1), "0000")
   
5.     Next

复制代码

我在set  d = Nothing前加了一段代码，就是把第一列工号又改回文本格式的0001 0002 这钟格式，但没有执行呢

ykcbf1100

andy117 发表于 2024-11-7 15:56
我在set  d = Nothing前加了一段代码，就是把第一列工号又改回文本格式的0001 0002 这钟格式，但没有执 ...

。。。。。。。。。。

ykcbf1100

。。。。。。。。。。

shiruiqiang

andy117 发表于 2024-11-7 15:56
我在set  d = Nothing前加了一段代码，就是把第一列工号又改回文本格式的0001 0002 这钟格式，但没有执 ...

改成：brr(m,d(s))="'" & arr(i,j)
即可。有个 ‘ 号

ykcbf1100

andy117 发表于 2024-11-7 15:56
我在set  d = Nothing前加了一段代码，就是把第一列工号又改回文本格式的0001 0002 这钟格式，但没有执 ...

改一下吧。

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, r&, iPosCol&, dic As Object, strPath$, strFileName$
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    With [A1].CurrentRegion
        .Offset(1).Clear
        ar = .Resize(10 ^ 3).Value: r = 1
        For j = 1 To UBound(ar, 2)
            dic(ar(1, j)) = j
        Next j
    End With
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xls")
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
            With GetObject(strPath & strFileName)
                br = .Worksheets(1).[A1].CurrentRegion.Value
                For i = 2 To UBound(br)
                    r = r + 1
                    For j = 1 To UBound(br, 2)
                        If dic.exists(br(1, j)) Then
                            iPosCol = dic(br(1, j))
                            ar(r, iPosCol) = br(i, j)
                        End If
                    Next j
                Next i
                .Close False
            End With
        End If
        strFileName = Dir
    Loop
   
    With [A1].Resize(r, UBound(ar, 2))
        .Value = ar
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

andy117

gwjkkkkk 发表于 2024-11-7 18:27
Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, r&, iPosCol&, dic As Object, strPath$, strFile ...

感谢~~~~~~~~~~~