主题:[讨论]VBA代码转VB问题
Sub test_1()
Rem Private Sub CommandButton1_Click()
Dim wb As Workbook, f, drr, brr(), crr(), d As Object
Dim m As Integer, n As Long, lr As Long, temp As String, i As Long, j As Integer, k As Integer
f = Application.GetOpenFilename(fileFilter:="Microsoft Excel Files (*.xls;*.xlsx),*.xls;*.xlsx", MultiSelect:=True, Title:="Ñ¡ÔñºÏ²¢Îļþ")
If TypeName(f) = "Boolean" Then Exit Sub
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
ActiveSheet.UsedRange.Clear
For k = 1 To UBound(f)
If f(k) <> ThisWorkbook.FullName Then
Set wb = Workbooks.Open(f(k))
m = m + 1
With wb.Sheets(1)
If m = 1 Then .Rows("1:1").Copy Cells(1, 1)
lr = .Range("A1").End(xlDown).Row
If lr > 1 Then '1
drr = .Range("A2:j" & lr) 'ÕâÀïÏÂÒÆÒ»ÐÐ A2
For i = 1 To UBound(drr)
temp = "" 'ÕâÀï·ÅÔÚtemp¸³ÖµÖ®Ç°
For j = 1 To 10
temp = temp & drr(i, j)
Next
If Not d.exists(temp) Then
n = n + 1
d(temp) = ""
ReDim Preserve brr(1 To 10, 1 To n)
For j = 1 To 10
brr(j, n) = drr(i, j)
Next
End If
Next
End If
End With
wb.Close False
End If
Next
If n > 0 Then
ReDim crr(1 To n)
With Cells(2, 1).Resize(n, 10) 'ÅÅÐò3
.Value = WorksheetFunction.Transpose(brr)
.Borders.LineStyle = xlContinuous
End With
With CreateObject("VBScript.RegExp")
.Pattern = "(\d{1,8})"
For i = 1 To n
If .test(brr(1, i)) Then crr(i) = .Execute(brr(1, i))(0)
Next
End With
Cells(2, 11).Resize(n) = WorksheetFunction.Transpose(crr) 'ÅÅÐò2
Range("A3").Resize(n, 11).Sort Key1:=Range("k3").Resize(n) '±íͷλÖã¨A3£ºÍ·²¿ A2£ºÎ²²¿£©
Columns("k:k").ClearContents
End If
Application.ScreenUpdating = True
MsgBox "´¦ÀíÍê±Ï"
End Sub
请教各位前辈,以上是VBA的代码,在VB中如何编写,请老师帮忙。。谢谢
Rem Private Sub CommandButton1_Click()
Dim wb As Workbook, f, drr, brr(), crr(), d As Object
Dim m As Integer, n As Long, lr As Long, temp As String, i As Long, j As Integer, k As Integer
f = Application.GetOpenFilename(fileFilter:="Microsoft Excel Files (*.xls;*.xlsx),*.xls;*.xlsx", MultiSelect:=True, Title:="Ñ¡ÔñºÏ²¢Îļþ")
If TypeName(f) = "Boolean" Then Exit Sub
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
ActiveSheet.UsedRange.Clear
For k = 1 To UBound(f)
If f(k) <> ThisWorkbook.FullName Then
Set wb = Workbooks.Open(f(k))
m = m + 1
With wb.Sheets(1)
If m = 1 Then .Rows("1:1").Copy Cells(1, 1)
lr = .Range("A1").End(xlDown).Row
If lr > 1 Then '1
drr = .Range("A2:j" & lr) 'ÕâÀïÏÂÒÆÒ»ÐÐ A2
For i = 1 To UBound(drr)
temp = "" 'ÕâÀï·ÅÔÚtemp¸³ÖµÖ®Ç°
For j = 1 To 10
temp = temp & drr(i, j)
Next
If Not d.exists(temp) Then
n = n + 1
d(temp) = ""
ReDim Preserve brr(1 To 10, 1 To n)
For j = 1 To 10
brr(j, n) = drr(i, j)
Next
End If
Next
End If
End With
wb.Close False
End If
Next
If n > 0 Then
ReDim crr(1 To n)
With Cells(2, 1).Resize(n, 10) 'ÅÅÐò3
.Value = WorksheetFunction.Transpose(brr)
.Borders.LineStyle = xlContinuous
End With
With CreateObject("VBScript.RegExp")
.Pattern = "(\d{1,8})"
For i = 1 To n
If .test(brr(1, i)) Then crr(i) = .Execute(brr(1, i))(0)
Next
End With
Cells(2, 11).Resize(n) = WorksheetFunction.Transpose(crr) 'ÅÅÐò2
Range("A3").Resize(n, 11).Sort Key1:=Range("k3").Resize(n) '±íͷλÖã¨A3£ºÍ·²¿ A2£ºÎ²²¿£©
Columns("k:k").ClearContents
End If
Application.ScreenUpdating = True
MsgBox "´¦ÀíÍê±Ï"
End Sub
请教各位前辈,以上是VBA的代码,在VB中如何编写,请老师帮忙。。谢谢