返回列表 上一主題 發帖

多頁出貨資料如何在新分頁依範圍日期選出排列呢?

本帖最後由 Hsieh 於 2012-9-5 16:26 編輯

回復 4# jimmy510
不知道是不是這個意思
彙整資料又有計算欄位可能用VBA比較單純
  1. Sub ex()
  2. Dim ar()
  3. ReDim Preserve ar(s)
  4. ar(s) = Array("尺寸", "日期", "數量", "單價", "總額", "備註")
  5. s = 1
  6. st = InputBox("輸入起始日期", , Format(DateAdd("M", -12, Date), "e/m/d"))
  7. st1 = InputBox("輸入起始日期", , Format(Date, "e/m/d"))
  8. For Each sh In Sheets
  9. With sh
  10.    If .Name Like "刀模*" Then
  11.      For Each a In .Range(.[A3], .Cells(.Rows.Count, 1).End(xlUp))
  12.        If CDate(a) >= CDate(st) And CDate(a) <= CDate(st1) Then
  13.           ReDim Preserve ar(s)
  14.           ar(s) = Array(.[A1].Value, a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 1).Value * a.Offset(, 2).Value, a.Offset(, 3).Value)
  15.           s = s + 1
  16.        End If
  17.      Next
  18.     End If
  19. End With
  20. Next
  21. If s > 1 Then
  22. With Worksheets.Add(after:=Sheets(Sheets.Count))
  23. .[A1].Resize(s, 6) = Application.Transpose(Application.Transpose(ar))
  24. End With
  25. Else
  26. MsgBox "沒有符合資料"
  27. End If
  28. End Sub
複製代碼
學海無涯_不恥下問

TOP

ˋ回復 6# jimmy510


    你的日期並非正確的日期格式
例如99/9/3這會被認為是1999/9/3
可能是你的日期超出系統許可日期範圍
導致Cdate函數出錯
請上傳錯誤檔案以釐清原因
學海無涯_不恥下問

TOP

回復 8# jimmy510



    當工作表A3以下沒有日期資料才會出錯
  1. Sub 出貨查詢()
  2. Dim ar()
  3. ReDim Preserve ar(s)
  4. ar(s) = Array("尺寸", "日期", "數量", "單價", "總額", "備註")
  5. s = 1
  6. st = InputBox("輸入起始日期", , Format(DateAdd("M", -12, Date), "e/m/d"))
  7. st1 = InputBox("輸入起始日期", , Format(Date, "e/m/d"))
  8. For Each sh In Sheets
  9. With sh
  10.    If .Name Like "刀模*" Then
  11.      For Each a In .Range(.[A3], .Cells(.Rows.Count, 1).End(xlUp))
  12.      If Not IsDate(a) Then GoTo 10
  13.        If CDate(a) >= CDate(st) And CDate(a) <= CDate(st1) Then
  14.           ReDim Preserve ar(s)
  15.           ar(s) = Array(.[A1].Value, a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 1).Value * a.Offset(, 2).Value, a.Offset(, 3).Value)
  16.           s = s + 1
  17.        End If
  18. 10
  19.      Next
  20.     End If
  21. End With
  22. Next
  23. If s > 1 Then
  24. With Worksheets.Add(after:=Sheets(Sheets.Count))
  25. .[A1].Resize(s, 6) = Application.Transpose(Application.Transpose(ar))
  26. End With
  27. Else
  28. MsgBox "沒有符合資料"
  29. End If
  30. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 滴水成河。粒米成蘿,勿輕己靈,勿以善小而不為。
返回列表 上一主題