已解决 差旅费报销单

学良

       这是给同事做的一个表,有兰色的单元格设有公式,不必填写亦不要删除.
       但个人觉得,若能每次打印时将其保存在[差旅费报销清单]表中就完美了.因本人不甚熟练VBA,
只能在此向各位老师求助,诚望各位高师帮忙写写代码完成录入功能!
       我已作好了模似效果表,请您费心看看.
       其实我也找了很多类似录入的表格,作了多次试验匀未成功,只好作一个另存表格的功能,
但仍不如录入功能方便实用,无耐只能做一次"申手党",辛苦您了!
                    谢谢!  
    期待传来喜讯.

差旅费报销单-Q.zip (38.14 KB, 下载次数: 687)

2020-2-6 16:02 上传

点击文件名下载附件

在liulang0808 版主和一把小刀闯天下, wodewan ,  海好呀 老师们帮助下,  已经园满解决,现将完整版发上来,

liulang0808

1. Sub 按钮3_Click()
   
2.     [a1:n27].PrintOut
   
3.     arr = Sheets("差旅费报销清单").UsedRange
   
4.     r = UBound(arr) + 1
   
5.     Application.ScreenUpdating = False
   
6.     With Sheets("差旅费报销清单")
   
7.         .Cells(r, 1) = r - 2
   
8.         For i = 2 To UBound(arr, 2)
   
9.             If InStr(arr(2, i), "-") > 0 Then
   
10.                 str1 = Split(arr(2, i), "-")(0)
    
11.             Else
    
12.                 str1 = arr(2, i)
    
13.             End If
    
14.             .Cells(r, i) = Range(str1)
    
15.         Next i
    
16.     End With
    
17.     Application.ScreenUpdating = True
    
18. End Sub
    

复制代码

liulang0808

不知道理解的对不对，供参考。。。。。。

罗达

差旅费报销单-.zip (41.7 KB, 下载次数: 120)

2020-2-5 16:36 上传

点击文件名下载附件

学良老师是大神哦，表格设计（尤其财务）的那叫一个亮！一直膜拜。现有代码未做保存后的数据清空，如需要请回复。

学良

liulang0808 发表于 2020-2-5 15:09
不知道理解的对不对，供参考。。。。。。

非常感谢版主出手相助!  是我没说清楚.
我要的效果是象[模似效果表]那样, 点一次按扭,将[差旅费报销单]表中的数据全部录入至[差旅费报销清单]表中,
现在点一次只将第一行数据录入进去了.  请您再给看看. 谢谢了!

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, t, a, b, c, d, e, pos
  pos = Sheets("差旅费报销清单").[a1].CurrentRegion.Offset(1).Resize(1).Value
  ReDim arr(1 To 10 ^ 3, 1 To UBound(pos, 2))
  With Sheets("差旅费报销单")
    t = Split(pos(1, 7), "-")
    a = Val(Mid(t(0), 2)): b = Val(Mid(t(1), 2))
    For j = 2 To UBound(pos, 2)
      If InStr(pos(1, j), "-") Then
        t = Split(pos(1, j), "-")
        c = Val(Mid(t(0), 2)): d = Val(Mid(t(1), 2)): e = Left(t(0), 1)
        For i = c To d
          arr(i - c + 1, j) = .Range(e & i).Value
        Next
      Else
        For i = a To b
          arr(i - a + 1, j) = .Range(pos(1, j)).Value
        Next
      End If
    Next
  End With
  With Sheets("差旅费报销清单")
    .Range("b:b, g:g, i:i").NumberFormatLocal = "yyyy/mm/dd"
    With .Cells(.Cells(Rows.Count, "b").End(xlUp).Row + 1, "a").Resize(b - a + 1, UBound(arr, 2))
      .Borders.LineStyle = xlContinuous
      .Value = arr
    End With
  End With
End Sub

liulang0808

之前理解有误
现在按照需求模拟了，供餐卡
第二张表的，第二行需要保留，偷懒直接借用了

YZC51

一把小刀闯天下 发表于 2020-2-5 16:05
Option Explicit

Sub test()

学习老师的代码。谢谢老师！
Sub test()
  Dim arr, i, j, t, a, b, c, d, e, pos
  pos = Sheets("差旅费报销清单").[a1].CurrentRegion.Offset(1).Resize(1).Value
  rq = Format(Now, "yymmddhhmmss")
  ReDim arr(1 To 10 ^ 3, 1 To UBound(pos, 2))
  With Sheets("差旅费报销单")
    t = Split(pos(1, 7), "-")
    a = Val(Mid(t(0), 2)): b = Val(Mid(t(1), 2))
    For j = 2 To UBound(pos, 2)
      If InStr(pos(1, j), "-") Then
        t = Split(pos(1, j), "-")
        c = Val(Mid(t(0), 2)): d = Val(Mid(t(1), 2)): e = Left(t(0), 1)
        For i = c To d
          arr(i - c + 1, j) = .Range(e & i).Value
        Next
      Else
        For i = a To b
        arr(i - a + 1, 1) = rq
          arr(i - a + 1, j) = .Range(pos(1, j)).Value
        Next
      End If
    Next
  End With
  With Sheets("差旅费报销清单")
    .Range("b:b, g:g, i:i").NumberFormatLocal = "yyyy-mm-dd"
    .Range("A:A").NumberFormatLocal = "000000"
    With .Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "a").Resize(b - a + 1, UBound(arr, 2))
      .Borders.LineStyle = xlContinuous
      .Value = arr
    End With
  End With
End Sub

学良

liulang0808 发表于 2020-2-5 16:07
之前理解有误
现在按照需求模拟了，供餐卡
第二张表的，第二行需要保留，偷懒直接借用了

基本成功了, 您辛苦了!
美中不足的是[差旅费报销单]的18行至21行,只有两行有数据,而[差旅费报销清单]中却复制了八行.
如果把多余的行数空出来,那就完美了.   有时间时您再给看看, 不好意思,让您受累了!

罗达

一把小刀闯天下 发表于 2020-2-5 16:05
Option Explicit

Sub test()

厉害，就像函数嵌套，学习了