還原與備份

myleoyes

各位前輩你們好!
　　      前輩!問題如附檔案說明　
            請知道的前輩,不吝賜教謝謝再三!!

GBKEE

回復 1# myleoyes

1. Sub 還原()
   
2.     Dim F As Range
   
3.     With ActiveSheet
   
4.         Set F = .Rows(1).Cells.Find(.Cells(1, ActiveCell.Column))
   
5.         If F = "" Then
   
6.             MsgBox "沒有標題"
   
7.             Exit Sub
   
8.         End If
   
9.         Set F = .Range(F.Offset(2), F.Offset(, 20).End(xlDown))
   
10.     End With
    
11.     Sheets("分析").Select
    
12.     Range("A3:U" & Range("A3").End(xlDown).Row).Clear
    
13.     F.Copy Range("A3")
    
14. End Sub

複製代碼

myleoyes

GBKEE前輩你好!
　　　　 良師!!哇太棒囉!!接著備份程式請再辛苦囉!
              如附檔案說明請再辛苦囉!謝謝再三!!

GBKEE

回復 3# myleoyes

1. Sub 比對備份()
   
2.     Dim d As Object, Rng As Range, E As Range, M%, R, i%
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("比對備份")
   
5.         If .Range("iv1").End(xlToLeft).Column > 1 Then '已有備份資料
   
6.             Set Rng = .Range("B1", .Range("iv1").End(xlToLeft))  '備份資料欄位範圍
   
7.             Set E = Rng(1, Rng.Columns.Count + 1)   '設立要加入備份資料欄位的位置
   
8.             M = Application.Max(Rng)                '取得已有備份資料中第1列內相同項目的最大數
   
9.         Else                                        '沒有備份資料
   
10.             Set E = .Range("B1")
    
11.             M = 0
    
12.         End If
    
13.     End With
    
14.     Set Rng = Range("A1").CurrentRegion
    
15.     Set Rng = Range("C1", Rng(Rng.Rows.Count, Rng.Columns.Count)) '備份資料的範圍
    
16.     i = 1
    
17.     For Each R In Rng.Rows(1).Cells
    
18.         If Not d.Exists(R.Value) Then
    
19.             d(R.Value) = i   '設定複製資料內第1列相同項目的數值
    
20.             i = i + 1
    
21.         End If
    
22.     Next
    
23.     Rng.Copy E
    
24.     i = 0
    
25.     Do While E.Offset(, i) <> ""
    
26.         If d.Exists(E.Offset(, i).Value) Then E.Offset(, i) = d(E.Offset(, i).Value) + M
    
27.         '修改複製資料後 第1列相同項目新增的數值
    
28.         '->設定複製資料內第1列相同項目的數值 + 已有備份資料中第1列內相同項目的最大數
    
29.         i = i + 1
    
30.     Loop
    
31. End Sub

複製代碼

myleoyes

回復 4# GBKEE
GBKEE前輩你好!
　　　　 良師!!程式的編號有出入...
              如附檔案說明請再辛苦囉!謝謝再三!!
              晚安!!

GBKEE

回復 5# myleoyes
請加上紅色部分
Do While E.Offset(, i) <> ""
        If d.Exists(E.Offset(, i).Value) Then E.Offset(, i) = d(E.Offset(, i).Value) + M
        '修改複製資料後 第1列相同項目新增的數值
        '->設定複製資料內第1列相同項目的數值 + 已有備份資料中第1列內相同項目的最大數
        i = i + 1
    Loop

myleoyes

回復 6# GBKEE
GBKEE前輩你好!
　　　　 良師!!不好意思請再幫忙這個刪除鈕
                  如附檔案說明請再辛苦囉!謝謝再三!!

GBKEE

回復 7# myleoyes

1. Sub 刪除()
   
2.     Dim F As Range, i%
   
3.     With ActiveSheet
   
4.         Set F = .Rows(1).Cells.Find(.Cells(1, ActiveCell.Column))
   
5.         i = 1
   
6.         Do
   
7.             If F.Offset(, i) <> F Then
   
8.                 Set F = .Range(F, F.Offset(, i - 1))
   
9.                 Exit Do
   
10.             End If
    
11.             i = i + 1
    
12.         Loop
    
13.     End With
    
14.     F.EntireColumn.Delete
    
15. End Sub

複製代碼

myleoyes

回復 8# GBKEE
  
GBKEE前輩你好!
　　　　 良師!!程式有問題
            如附檔案說明請再辛苦囉!謝謝再三!!

GBKEE

回復 9# myleoyes
我執行沒有問題的 選擇那一個編號 就刪掉那一個編號的範圍沒錯
為防止錯誤修改如下

1. Sub 刪除()
   
2.     Dim F As Range, i%
   
3.     If ActiveCell.Column <= 2 Then Exit Sub
   
4.     With ActiveSheet
   
5.         Set F = .Rows(1).Cells.Find(.Cells(1, ActiveCell.Column))
   
6.         If F = "" Then Exit Sub
   
7.         i = 1
   
8.         Do
   
9.             If F.Offset(, i) <> F Then
   
10.                 Set F = .Range(F, F.Offset(, i - 1))
    
11.                 Exit Do
    
12.             End If
    
13.             i = i + 1
    
14.         Loop
    
15.     End With
    
16.     F.EntireColumn.Delete
    
17. End Sub

複製代碼