|
- Sub 多薄填写()
- Dim wb As Workbook
- Dim mypath$, myname$
- Dim d As Object, a, sa
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- mypath = ThisWorkbook.Path & ""
- myname = Dir(mypath & "*.xlsx")
- Do While myname <> ""
- If myname <> ThisWorkbook.Name Then
- Set wb = GetObject(mypath & myname)
- If Left(wb.Name, 1) = "A" Then
- a = Application.WorksheetFunction.RandBetween(1, 5)
- sa = Sheet1.Cells(a + 1, 1)
- ElseIf Left(wb.Name, 1) = "B" Then
- a = Application.WorksheetFunction.RandBetween(1, 4)
- sa = Sheet1.Cells(a + 9, 1)
- ElseIf Left(wb.Name, 1) = "C" Then
- a = Application.WorksheetFunction.RandBetween(1, 4)
- sa = Sheet1.Cells(a + 17, 1)
- End If
- Windows(wb.Name).Visible = True
- With wb
- .Worksheets(1).[B8] = " " & sa
- .Save
- .Close
- End With
- End If
- myname = Dir
- Loop
- Application.ScreenUpdating = True
- MsgBox "数据填写完毕!"
- End Sub
复制代码 |
|