資料無法正確寫入儲存格

feecshyrnd

小弟想在公司的EXCEL檔案裡加入個人獨立帳密登入方式
目前是每登入一次,會寫入一筆資料
反之是登入錯誤也會寫入資料
小弟目前遇到的問題是 登入錯誤無法跟正確登入一樣 持續往下一列寫入資料
而是在同一儲存格裡覆蓋原有資料
能否請各位高手幫小弟解惑呢???

紅色部份是小弟增加要判斷登入錯誤,並寫入儲存格的 (原本並沒有那一段)

Private Sub CommandButton1_Click()
Sheet2.Visible = True
Sheets("交接事項").Activate
Dim UserId As String
Dim N As Long
Dim FD As Range
Set FD = Range("a65536").End(xlUp).Offset(1, 0)
Dim Ar, a1, i% '此處宣告3個欄位
a1 = TextBox1
Ar = Array(a1)  '欄位儲存於陣列
UserId = TextBox1.Value
If UserId = "" Then
  MsgBox "請輸入ID"
  GoTo 101
  End If
For N = 1 To 300
  
   If Sheet3.Cells(N, 5).Value = UserId Then
            If Sheet3.Cells(N, 6).Value = TextBox2.Value Then
            MsgBox "登入成功"
if a1 <> "" Then  '判斷所有值都不等於空白
       i = 2   '第一列開始
       Do Until Cells(i, 1) = ""  'A欄為空白則停止迴圈
       i = i + 1  '向下一列
       Loop
       Cells(i, 3).Resize(, 1) = Ar  'A欄空白向右擴展成欄位數量

FD = Date  '往右一格寫入當前時間
FD.Offset(0, 1) = Time '往右二格寫入txtID的資料

    End If
            UserForm1.Hide
            GoTo 101
            Else
   MsgBox "登入失敗"

       i = 2   '第一列開始
       Do Until Cells(i, 1) = ""  'A欄為空白則停止迴圈
       i = i + 1  '向下一列
       Loop
       Cells(i, 10).Resize(, 1) = Ar  'A欄空白向右擴展成欄位數量

FD.Offset(0, 8) = Date '往右一格寫入當前時間
FD.Offset(0, 9) = Time '往右二格寫入txtID的資料

    End If
        
            GoTo 101
            Exit For
            End If
  end if   
  Next
GoTo 100

100
MsgBox "帳號錯誤"
'GoTo 1100 '為統計登入正確或強制登入記錄,故登入錯誤也列入資料
UserForm1.TextBox2.Value = ""
UserForm1.TextBox1.Value = ""
'Sheets("sheet1").Activate '停留在登入頁面避免跑到帳密頁面
Exit Sub

101
UserForm1.Hide

UserForm1.TextBox1.Value = ""
UserForm1.TextBox2.Value = ""

'Sheets("sheet1").Activate '停留在登入頁面避免跑到帳密頁面

End Sub

Private Sub CommandButton2_Click()
UserForm1.Hide
UserForm1.TextBox1.Value = ""
UserForm1.TextBox2.Value = ""
End Sub

雪舞子

i = 2   '第一列開始
       Do Until Cells(i, 1) = ""  'A欄為空白則停止迴圈
       i = i + 1  '向下一列
       Loop
       Cells(i, 10).Resize(, 1) = Ar  'A欄空白向右擴展成欄位數量
Set FD = Range("a65536").End(xlUp).Offset(1, 0)
FD.Offset(0, 8) = Date '往右一格寫入當前時間
FD.Offset(0, 9) = Time '往右二格寫入txtID的資料


没有具体附件，不知为何物，
只是根据代码判断一下，
在楼主添加的代码中再添加一句蓝色代码试试看。

feecshyrnd

雪舞子 发表于 2016-1-17 15:40
i = 2   '第一列開始
       Do Until Cells(i, 1) = ""  'A欄為空白則停止迴圈
       i = i + 1  '向下 ...

加了還是一樣,因為無法上傳附件 傳至 mega 麻煩幫忙了

mega.nz/#!6JFkmYgJ!t45SUV7K2eJT2Q9FlBFxt3A3KyHNJIlfEpRUqx7HHUU

雪舞子

i = 2   '第一列開始
       Do Until Cells(i, 10) = ""  'A欄為空白則停止迴圈
       i = i + 1  '向下一列
       Loop
       Cells(i, 10).Resize(, 1) = Ar  'A欄空白向右擴展成欄位數量
Set FD = Range("h65536").End(xlUp).Offset(1, 0)
FD= Date '往右一格寫入當前時間
FD.Offset(0, 1) = Time '往右二格寫入txtID的資料

楼主这里的跟原档有些区别，
看这里代码能大致明白一些你的意思，
这样改下再试试看。