我现在有会计分录序时簿一个文件。
它的内容是下面这个样子，我现在需要先提取每张凭证的借贷会计科目，然后反写到每一行数据中。
这样做的目的在于按照每张凭证的借贷会计科目来对凭证进行业务分类，从而达到分析的目的。完成后我们可以做的有：
1.按照借贷科目对凭证进行分类将会更加准确。
2.分类之后可以直接关联每种类型中货币资金的去向，用更直接简单的方法来编制现金流量表。


现在添加了附件如下：


以下代码是我在VBA中用到的。能满足要求。
但我的数据源本身就是VFP，还请乡亲们帮忙提供解决思路或者解决方案，谢谢。

Sub 凭证一级科目提取()
    Dim br, cr(60000, 4), dc, dk, de, df, dw(60000, 1)
    br = [a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    bok1 = ActiveSheet.Name
    For xrow = 2 To UBound(br)
        If br(xrow, 10) = 0 Then
            方向 = "cr"
            Else: 方向 = "dr"
        End If
        If br(xrow, 2) & br(xrow, 3) <> dk Or xrow = UBound(br) Then
            Item = Item + 1
            If Item > 1 Then
                cr(Item - 1, 0) = dk    'key
                cr(Item - 1, 1) = dc    '科目
                cr(Item - 1, 2) = de    '摘要
                cr(Item - 1, 3) = df    '制单人
                dk = ""
                dc = ""
                de = ""
                df = ""
            End If
        End If
        dk = br(xrow, 2) & br(xrow, 3)
        If InStr(dc, 方向 & br(xrow, 23)) = False Then dc = dc & 方向 & br(xrow, 23)
        If InStr(de, Left(br(xrow, 5), 8)) = False Then de = Left(br(xrow, 5), 8)  '只要最后一个摘要。
        If InStr(df, Left(br(xrow, 12), 8)) = False Then df = df & Left(br(xrow, 12), 8)
    Next
    Sheets.Add
    Range(Cells(1, 1), Cells(Item, "e")) = cr
    [a1:d1] = Array("key", "科目", "摘要", "制单人")
    Cells.WrapText = False
    Sheets(bok1).Select
        For xx = 1 To UBound(cr)
            d(cr(xx, 0)) = cr(xx, 1)
        Next xx
        For yy = 2 To [a65536].End(xlUp).Row + 1
            dw(yy - 2, 0) = d(br(yy - 1, 2) & br(yy - 1, 3))
        Next yy
        Range(Cells(1, "ab"), Cells(UBound(br), "ab")) = Application.Index(dw, 0, 0)
        [ab1] = "凭证"
End Sub

[此贴子已经被作者于2018-11-22 20:54编辑过]

我自己想的思路是这样，首先创建一列用来记录每一行对应的科目，代码如下：

ALTER table te ADD COLUMN 科目 c(80)
UPDATE te SET 科目=IIF(dr=0,"dr","cr")-一级科目

运行代码后变成了下面这个结果。

[此贴子已经被作者于2018-11-22 16:34编辑过]

自己再进一步想到的代码便是：

ke =''
ce=''
DO WHILE not EOF()

    IF     会计期间-凭证字号=ke THEN 
        ce=ce-科目
    ELSE 
        REPLACE  kk WITH ce 
    ENDIF        
    ke =会计期间-凭证字号
skip
ENDDO 

仅仅只实现了部分希望的内容，而且还是一个错误的。我的希望是每一行都能填充我需要的内容。

[此贴子已经被作者于2018-11-22 16:49编辑过]

不明白。你是要把同一个凭证的贷方和借方合并为一条记录吗？

感谢你的回答，我的想法就是每一张凭证，我可以汇总出来这张凭证的借贷一级科目各是什么例如：“dr现金cr银行”等内容。然后把这些内容填写进入每一行分录中。

不晓得是不是你要的结果。

SELECT 会计期间,凭证字号,一级科目,SUM(dr) as 借方,SUM(cr) as 贷方,replicate(' ',20) as 科目 FROM alias() GROUP BY 会计期间,凭证字号,一级科目 into cursor _tmp readwrite
update _tmp set 科目=rtrim(一级科目)+'CR' where emtpy(借方)
update _tmp set 科目=rtrim(一级科目)+'DR' where emtpy(贷方)

处理结果是这样的

收到的鲜花

• hyz00001 于 2018-11-22 20:50 送鲜花  1朵   附言：谢谢你的帮助，刚才没有说清楚。

合并依据不充分，也就是没有规律。321　与359　原始记录数是一样的，但结果自相矛盾，最后生成的记录数也不一样多。

收到的鲜花

• hyz00001 于 2018-11-22 20:50 送鲜花  2朵   附言：感谢sdta关注问题，谢谢你！

感谢大神sdta的答复，谢谢你！

 很抱歉没有表述清楚，现在编制一个excel再解释下：


合并凭证的excel档案在下面：

[此贴子已经被作者于2018-11-22 20:38编辑过]

* ＶＦＰ９代码

SELECT *,SPACE(100) 合并结果 FROM test ORDER BY 凭证字号, 一级科目 INTO CURSOR tt READWRITE 
STORE 0 TO nRec1, nRec2
STORE "" TO cStr, c凭证字号, c一级科目
SCAN
    IF 凭证字号 == c凭证字号
        IF 一级科目 != c一级科目
            cStr = cStr - IIF(dr != 0, "dr", "cr") - 一级科目
        ENDIF 
        nRec2 = RECNO()
    ELSE
        IF NOT EMPTY(cStr)
            REPLACE 合并结果 WITH cStr FOR BETWEEN(RECNO(), nRec1, nRec2)
            GO nRec2 + 1
            cStr = ""
        ENDIF 
        cStr = IIF(dr != 0, "dr", "cr") + 一级科目
        nRec1 = RECNO()
    ENDIF 
    c凭证字号 = 凭证字号
    c一级科目 = 一级科目
ENDSCAN
REPLACE 合并结果 WITH cStr FOR BETWEEN(RECNO(), nRec1, RECCOUNT())
GO BOTTOM 
BROWSE 

[此贴子已经被作者于2018-11-22 21:54编辑过]

收到的鲜花

• hyz00001 于 2018-11-22 21:54 送鲜花  2朵   附言：太感谢sdta,完美解决问题。