数值保存到另外工作簿指定工作表中

15968725770

数值保存到另外工作簿指定工作表中

半百

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar, i&, strFileName$, strPath$, iRow&
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "保存到指定工作表中.xlsm"
    If Dir(strFileName) = "" Then MsgBox "指定的文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
   
    ar = [A1].CurrentRegion.Value
    With Workbooks.Open(strFileName)
        If isWksExists1("类别" & ar(2, 1)) Then
            With .Sheets("类别" & ar(2, 1))
                iRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                .Cells(iRow, 1) = ar(2, 1)
                .Cells(iRow, 2) = ar(2, 2)
            End With
        Else
            With .Sheets.Add(after:=.Sheets(.Sheets.Count))
                .Name = "类别" & ar(2, 1)
                .[A1].Resize(UBound(ar), UBound(ar, 2)) = ar
            End With
        End If
         .Close True
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub
Public Function isWksExists1(wksName As String) As Boolean
    On Error Resume Next
    isWksExists1 = Sheets(wksName).Name = wksName
End Function

gwjkkkkk

请参考。。。。

ykcbf1100

附件供参考，不会重复保存。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.2.25
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Set sh = ThisWorkbook.Sheets("录入")
   
7.     s = sh.[a2]
   
8.     d(s) = sh.[b2]
   
9.     p = ThisWorkbook.Path & ""
   
10.     f = p & "保存到指定工作表中.xlsm"
    
11.     Set wb = Workbooks.Open(f, 0)
    
12.     With wb.Sheets("类别" & s)
    
13.         r = .Cells(Rows.Count, 1).End(3).Row
    
14.         For i = 2 To r
    
15.             d1(.Cells(i, 2)) = ""
    
16.         Next
    
17.         If Not d1.exists(d(s)) Then
    
18.             .Cells(r, 1) = s
    
19.             .Cells(r, 2) = d(s)
    
20.         End If
    
21.     End With
    
22.     wb.Close 1
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox "OK！"
    
25. End Sub
    
26. 
    

复制代码

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.2.25
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Set sh = ThisWorkbook.Sheets("录入")
   
7.     s = sh.[a2]
   
8.     d(s) = sh.[b2]
   
9.     p = ThisWorkbook.Path & ""
   
10.     f = p & "保存到指定工作表中.xlsm"
    
11.     Set wb = Workbooks.Open(f, 0)
    
12.     With wb.Sheets("类别" & s)
    
13.         r = .Cells(Rows.count, 1).End(3).Row
    
14.         For i = 2 To r
    
15.             d1(.Cells(i, 2)) = ""
    
16.         Next
    
17.         If Not d1.exists(d(s)) Then
    
18.             .Cells(r, 1) = s
    
19.             .Cells(r, 2) = d(s)
    
20.         End If
    
21.     End With
    
22.     wb.Close 1
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox "OK！"
    
25. End Sub
    

复制代码

15968725770

ykcbf1100 发表于 2024-2-25 20:48
附件供参考，不会重复保存。

D:/Desktop/数值保存到另外工作簿指定工作表中/QQ截图20240226174421.jpg

15968725770

ykcbf1100 发表于 2024-2-25 20:48
附件供参考，不会重复保存。

老师你好，类别可以重复，编码不可以重复

ykcbf1100

15968725770 发表于 2024-2-26 17:47
老师你好，类别可以重复，编码不可以重复

现在的代码就是这样的。