[原创]VBA锁定新方法

button

THANKS TO GZK、ROWEN、WSWX、KEVIN&EXCELHOME： 无意中发现了一种VBA锁定的新方法，不需要VBA密码，也不需要VBALOCK，出现“工程不可查看”。 以下是实现的例子，效果与LOCKVBA是否一样？ 如果可以保证无法解密，说明此方法可行！[upload=rar]uploadImages/20027101518426146.rar[/upload]

linhuer

你是如何做到的?

button

这个论坛不允许将这种方法随便说出，也许诸位要失望了，但我可以明确说明，我是借助于第三方工具的。还可以反向工程，但不会很容易。

http

你这种VBA锁定新方法看来挺有效 不便说出可以理解 但我很想学习你是怎样把原示数据排列成期望格式的 把这段代码说出让大家学学 吧

button

to http 谢谢您的理解！ 代码见下： Sub band0621() On Error Resume Next Dim i, j As Integer Dim x As String Columns("B:IV").Select Selection.NumberFormatLocal = "@" Columns("C:C").Select Application.CutCopyMode = True '数据分列 Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=True, Space:=False, Other:=False '数据移动 For i = 1 To 1000 For j = 1 To 1000 If Cells(i, 2 + j) <> "" Then Cells(i + j, 2).Select Selection.NumberFormatLocal = "@" Selection.EntireRow.Insert Cells(i + j, 2) = Cells(i, 2 + j) Cells(i + j, 1) = Cells(i, 1) Cells(i, 2 + j).Clear Else Exit For End If Next j, i Columns("C:C").Select Selection.Delete Shift:=xlToLeft End Sub 例子而已，作的并不是很好。

wswx

To:button 你的文件可以破解，见Email！

xls901

好像只认“，”分隔符

122081587

那怎么才可以破解呢

chchw2008

不行 还是被我破解了

Private Sub CommandButton1_Click() band0621 End Sub

还有一个还有一个fenlie 模块，其中内容就是上面的代码

benteng302

不好意思斑竹。

Sub band0621()
On Error Resume Next

Dim i, j As Integer
Dim x As String
Columns("B:IV").Select
Selection.NumberFormatLocal = "@"
Columns("C:C").Select
Application.CutCopyMode = True
'数据分列
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False
'移动数据
For i = 1 To 1000
For j = 1 To 1000
If Cells(i, 2 + j) <> "" Then
Cells(i + j, 2).Select
Selection.NumberFormatLocal = "@"
Selection.EntireRow.Insert
Cells(i + j, 2) = Cells(i, 2 + j)
'Cells(i + j, 2) = LCase(Cells(i, 2 + j))'如果出现大小写混乱，使用本行代码
Cells(i + j, 1) = Cells(i, 1)
Cells(i, 2 + j).Clear
Else
Exit For
End If
Next j, i
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
End Sub