返回列表 上一主題 發帖

請問我要如何改vba

JEAN

帖子
91 
主題
20 
精華
0 
積分
118 
點名
0  
作業系統
WINDOWS 
軟體版本
XP 
閱讀權限
20 
性別
女 
註冊時間
2011-11-30 
最後登錄
2016-1-14 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2013-7-16 16:20 | 只看該作者

請問我要如何改vba

以下是原來的vba:

Sub 領用單寫入()
Dim Ar()
With Sheets("領用單")
If Cells(3, 2) = "" Then
MsgBox "請輸入部門"
Else
If Cells(4, 2) = "" Then
MsgBox "請輸入領用人名字"
Else
If Cells(3, 8) = "" Then
MsgBox "請輸入日期"
Else
If Application.CountA(.[A6:A16]) > 0 Then
For Each a In .[A6:A16].SpecialCells(xlCellTypeConstants)
  ReDim Preserve Ar(S)
  Ar(S) = Array(.[B3].Value, .[B4].Value, .[H3].Value, a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 3).Value, a.Offset(, 4).Value, a.Offset(, 5).Value, a.Offset(, 6).Value, a.Offset(, 7).Value)
  S = S + 1
Next
r = Application.CountA(Sheets("領用記錄明細表").[A:A]) + 2
r = Application.CountA(Sheets("領用記錄明細表 (2)").[A:A]) + 2
Sheets("領用記錄明細表").Cells(r, 1).Resize(S, 11) = Application.Transpose(Application.Transpose(Ar))
Sheets("領用記錄明細表 (2)").Cells(r, 1).Resize(S, 11) = Application.Transpose(Application.Transpose(Ar))

End If
End If
End If
End If
End With
End Sub


這個是我改的vba:

Sub 領用單寫入()
Dim Ar()
With Sheets("領用單")
If Cells(3, 2) = "" Then
MsgBox "請輸入部門"
Else
If Cells(4, 2) = "" Then
MsgBox "請輸入領用人名字"
Else
If Cells(3, 8) = "" Then
MsgBox "請輸入日期"
Else
If Application.CountA(.[A6:A16]) > 0 Then
For Each a In .[A6:A16].SpecialCells(xlCellTypeConstants)
  ReDim Preserve Ar(S)
  Ar(S) = Array(.[B3].Value, .[B4].Value, .[H3].Value, a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 3).Value, a.Offset(, 4).Value, a.Offset(, 5).Value, a.Offset(, 6).Value, a.Offset(, 7).Value., a.Offset(, 8).Valuea.Offset(, 9).Value)
  S = S + 1
Next
r = Application.CountA(Sheets("領用記錄明細表").[A:A]) + 2
r = Application.CountA(Sheets("領用記錄明細表 (2)").[A:A]) + 2
Sheets("領用記錄明細表").Cells(r, 1).Resize(S, 11) = Application.Transpose(Application.Transpose(Ar))
Sheets("領用記錄明細表 (2)").Cells(r, 1).Resize(S, 11) = Application.Transpose(Application.Transpose(Ar))

End If
End If
End If
End If
End With
End Sub

我複上我要改的圖片  
未命名.rar (59.27 KB)    未命名2.rar (91.79 KB)
收藏 分享

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
2#
發表於 2013-7-16 19:32 | 只看該作者
回復 1# JEAN
是否這裡沒改到?

Sheets("領用記錄明細表").Cells(r, 1).Resize(S, 13) = Application.Transpose(Application.Transpose(Ar))
Sheets("領用記錄明細表 (2)").Cells(r, 1).Resize(S, 13) = Application.Transpose(Application.Transpose(Ar))

TOP

JEAN

帖子
91 
主題
20 
精華
0 
積分
118 
點名
0  
作業系統
WINDOWS 
軟體版本
XP 
閱讀權限
20 
性別
女 
註冊時間
2011-11-30 
最後登錄
2016-1-14 
3#
發表於 2013-7-19 15:57 | 只看該作者
回復 2# stillfish00


   嗯嗯.好,謝謝您

TOP

        靜思自在 : 稻穗結得越飽滿，越會往下垂，一個人越有成就，就要越有謙沖的胸襟。
返回列表 上一主題