VBA 用循环法对数值赋值不成功，如何解决？

Question

【问题背景】
近期每天要远程打卡，每家公司打卡的数据会导出1张表，工作簿名为“A公司”，sheet1为当天已打卡名单。
要求根据原始的汇总名单(已在此表中）找出每家公司没打卡的人员。在工作簿名为“A公司”新建表格，然后把该公司要打卡所有员工信息贴进去，如未在sheet1中找到这个公司要打卡的人姓名，则I列表示N.A

【逻辑】
遍历文件夹中名称不等于自身的表格。
总名单表格为arr
新建的表格为arrnew ，基于公司名称相等。

【问题】
在用循环法给给arrnew数组赋值时候，
newarr（i，j）=arr（k，j）

arr（k，j）有数值，但arrnew=0，实在搞不懂为什么是0，然后即时窗口显示false

被这类问题困扰许久了，烦请各位高手帮忙看看，感激不尽~~~
注：数据中敏感信息已处理

（问题代码处）

原始的表格

要求跑完代码显示的样子

代码如下

Option Explicit

Sub text()
Dim sFName As String
Dim sFType As String
Dim sPath As String
Dim stra  As String
'筛选公司
Dim stra1    '筛选公司
Dim wb
Dim rng
Dim arr()
Dim newarr(1 To 3000, 1 To 3000)

Dim k As Integer
Dim i As Integer, j As Integer


arr = Range("A1:I3000")


stra = "上海环境研究中心有限公司->环境中心-总经理办公室"

stra1 = Left(stra, InStr(stra, "-") - 1)

sFName = Dir("ThisWorkbook.Path" & "*.xlsx")


Application.ScreenUpdating = False
Application.DisplayAlerts = False

Do While sFName <> ""
   If sFName <> ThisWorkbook.Name Then

       Workbooks.Open (sFName)

       ActiveWorkbook.Sheet (1)

    End If

i = 1
j = 1

For k = 1 To 3000

For j = 1 To 8
k = 1
  If arr(k, 9) = stra1 Then
     newarr(i, j) = arr(k, j)

  End If
Next j
  i = i + 1
Next k
  Debug.Print "newarr(i,j)" = newarr(i, j)


Sheets.Add After:=ActiveSheet
 ActiveSheet.Name = "result"
 Sheets("result").Select

  Range("a1").Resize(2000, 8) = newarr

MsgBox "finish"



  sFName = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Answer 1

从你提供的代码来看，问题应该出在循环中的代码逻辑上。具体地，对于每个表格，你通过循环遍历原始表格 arr，查找满足条件的员工信息，并将其复制到新表格的 newarr 数组中。但是，在这个循环中，你没有更新 k 的值，导致 arr(k, j) 的值一直是不变的，因此 newarr 中的值也一直是 0。

为了解决这个问题，你可以在根据条件查找到一条员工信息后，增加变量 k 的值，使得下一次循环时查找下一条员工信息。你可以按照以下的代码修改你的循环部分：

i = 1
j = 1
k = 1

Do While arr(k, 1) <> ""

  If arr(k, 9) = stra1 Then
    For j = 1 To 8
      newarr(i, j) = arr(k, j)
    Next j
    i = i + 1
  End If

  k = k + 1
Loop

这将会按照顺序找出 arr 中所有符合条件的信息，将其复制到 newarr 中，并且每次循环会更新 k 的值，使得下一次查找时可以找到下一个符合条件的信息。