对不起，可能我表达的不是很清楚 一开始sheet1就存在资料，以excel格式来说如下 A B C D E F G 1 one two three four five six 2 one 3 two 4 three 5 four 6 five 7 six 那假设今天有资料A内容是 one,two,three 资料B内容 three,four,five 经过比对在sheet7会出现three，那我加的动作是先把B1到G1放进data_c 把A2到A7放进data_d，再从sheet7抓资料，例子里只有three，所以先从A栏找出three 再从第一列找出资料A的第一个"one"，找出来後在B4栏里填入1这样 底下是一整天大大所写的比对资料程式片断 我想要去增加一些功能 但是修改完还是没有动静 我也不知道哪里出了问题，毕竟我不是专业出身 T_T 希望有大大能帮忙看一下 这里面总共有八个表 sheet1是我新增的一个表，目的是希望在比对资料後能找到相应的储存格填入值 sheet2是操作的画面 sheet3(资料A)用来跟sheet4(资料B)做比较 经过比较可以得到sheet5,6,7,8 分别代表资料A缺少的(5)、资料B缺少的(6)、资料A和B共有的(7) sheet8和sheet5一样就不多说了 PS. 前面有*的程式码是我自己增加的 Private Sub cmdCompareab_Click() Dim n As Integer '判断资料A的栏位数 Dim count_a, count_b, *count_row, *count_column As Double '资料A,B的笔数还有计算 新资料表的列数与栏数 Dim temp As String Dim num As String 这边因为在操作画面有地方可以填入资料A的栏数(B1)还有资料A(b2)与资料B(b3)的笔数 那如果使用者没有填入，程式会自动去搜寻， 所以才有以下程式码，findx和findy是副程式用来找出列数和栏数 n = Sheet2.Range("B1") count_a = Sheet2.Range("b2") '资料A列数 count_b = Sheet2.Range("b3") '资料B列数 *count_c = findx(Sheet1) '新资料表列数 *count_d = findy(Sheet1) '新资料表栏数 If Sheet2.Range("B1") = "" Then n = findy(Sheet3) End If If Sheet2.Range("b2") = "" Then count_a = findx(Sheet3) End If If Sheet2.Range("b3") = "" Then count_b = findx(Sheet4) End If Call cleardata ReDim data_c(count_c) ReDim data_d(count_d) If count_a > count_b Then ReDim data_a(count_a) ReDim data_b(count_a) Else ReDim data_a(count_b) ReDim data_b(count_b) End If s = ChrB(160) ' 的ascii '这个我看不懂要做什麽用@@ 底下这两个For回圈是我自己写的，从2开始的原因是新资料表的(1,1)是空白格 For i = 2 To count_c '将新资料列放入阵列 temp = "" For j = 1 To 1 temp = temp & Sheet1.Cells(i, j) '这边用&的符号的意思我不明白 Next 因为作者本来有用就延用了 data_c(i) = temp Next For i = 1 To 1 '将新资料栏放入阵列 temp = "" For j = 2 To count_d temp = temp & Sheet1.Cells(i, j) Next data_d(i) = temp Next 底下两个是原作者的For回圈 '将资料A读入阵列 For i = 1 To count_a temp = "" For j = 1 To temp = temp & Sheet3.Cells(i, j) Next data_a(i) = temp Next '将资料B读入阵列 For i = 1 To count_b temp = "" For j = 1 To n temp = temp & Sheet4.Cells(i, j) Next data_b(i) = temp Next '开始比较A,B资料，有*号部份是我添加上去的 我希望做到的部分是在比较出资料A和资料B相同的资料时， 从新资料表的栏中(data_d)找出相同的，也从列中找出与data_a(1)相同的 找出来後在新资料表的那格储存格填入1，因为是第一次尝试修改VB程式 也不懂到底是哪个环节出问题，目前只做到这，再後面就都是原作者的程式码 a = 0 b = 0 c = 0 *num = 1 For i = 1 To count_a For j = 1 To count_b If data_a(i) = data_b(j) Then '如果相等则列印出来 c = c + 1 For k = 1 To n temp = Sheet3.Cells(i, k) Sheet7.Cells(c, k) = temp *For L = 1 To count_d *If temp = data_d(L) Then *For m = 1 To count_c *If data_a(1) = data_c(m) Then *Sheet1.Cells(m,L).Value = num *End If *Next *End If *Next change_cell_format Sheet7.Cells(c, k), Sheet3.Cells(i, k) Next Exit For End If Next '後面可以省略不看 If j > count_b Then 'a的资料在b找不到 a = a + 1 For k = 1 To n temp = Sheet3.Cells(i, k) Sheet6.Cells(a, k) = temp Sheet8.Cells(a, k + n + 1) = temp change_cell_format Sheet6.Cells(a, k + n + 1), Sheet3.Cells(i, k) change_cell_format Sheet8.Cells(a, k + n + 1), Sheet3.Cells(i, k) '将不一样的资料变成红色 Sheet3.Cells(i, k).Font.Color = vbRed Next End If DoEvents Sheet2.Range("b4") = i / count_a Next For i = 1 To count_b For j = 1 To count_a If data_b(i) = data_a(j) Then '如果相等则离开 Exit For End If Next If j > count_a Then 'b的资料在a找不到 b = b + 1 For k = 1 To n temp = Sheet4.Cells(i, k) Sheet5.Cells(b, k) = temp Sheet8.Cells(b, k) = temp change_cell_format Sheet5.Cells(b, k), Sheet4.Cells(i, k) change_cell_format Sheet8.Cells(b, k), Sheet4.Cells(i, k) Sheet4.Cells(i, k).Font.Color = vbRed Next End If DoEvents Sheet2.Range("b5") = i / count_b Next End Sub --

※ 发信站: 批踢踢实业坊(ptt.cc) ◆ From: 163.13.202.235 ※ 编辑: one164 来自: 163.13.202.235 (02/13 14:09)