excel vba 1

 

Dim InParmType() As String
Dim OutParmType() As String
Dim InParm() As String
Dim OutParm() As String
Public Dbhandle As New DbProc

Dim strSql As String
Dim rs01 As ADODB.Recordset
Dim rs02 As ADODB.Recordset

Private Sub CommandButton1_Click()

    Dim I As Integer
   
   
    Dim Version As String
    Dim SubVersion As String
    Dim TargetMonth As String
    Dim PublishDate As String
    Dim Category As String
    Dim SubCategory As String
    Dim ProdMonth As String
   
    Dim SheetNO As Integer
    Dim RangePoint1 As String
    Dim RangePoint2 As String
    Dim RangePoint3 As Integer
   
    Dim MaxRowQty As Integer    '最大行数
    Dim ColQty As Integer       '每月实绩有几列数据
    Dim MonthQty  As Integer    '导几个月份的数据
    Dim Site As String
    Dim ModelCode As String
   
    '  20091015 Add Start
    Dim ImportUser As String    '导入人员
    Dim ImprotDate As String      '导入日期
    '  20091015 Add End
   
    Dim Book0   As Workbook
    Dim Sheet0a  As Worksheet
    
    Dim Book1   As Workbook
    Dim Sheet1a  As Worksheet
   
    Dim Book2   As Workbook
    Dim Sheet2a  As Worksheet
   
    Dim PathFile, SoureFile As String
   
   
    Set Book0 = Workbooks(ThisWorkbook.Name)
    Set Sheet0a = Book0.Worksheets(1)
   
    Sheet0a.Activate
   
    Version = Range("H5").Value
    SubVersion = Range("H7").Value
    TargetMonth = Range("H9").Value
    PublishDate = Range("H11").Value
    Category = Range("H13").Value
    SubCategory = Range("H15").Value
    SheetNO = Range("W5").Value
    RangePoint1 = Range("W7").Value  '工场名称
    RangePoint2 = Range("W9").Value  '
    RangePoint3 = Range("W11").Value
    ColQty = Range("W13").Value
    MonthQty = Range("W15").Value
    ProdMonth = Range("W17").Value
   
    '  20091015 Add Start
    ImportUser = Range("H17").Value
    ImprotDate = Range("W19").Value
    '  20091015 Add End
   
   
    MaxRowQty = 100
   
   
    If Not IsDate(Format(TargetMonth, "####/##")) Then
        MsgBox ("[当前月份]日期或格式不正确，格式必须为YYYYMM，年4位，月2位")
        Exit Sub
     End If
    
    If Not IsDate(Format(ProdMonth, "####/##")) Then
        MsgBox ("[起始年月]日期或格式不正确，格式必须为YYYYMM，年4位，月2位")
        Exit Sub
     End If    
    
   
     If Not IsDate(Format(ImprotDate, "####/##/##")) Then
        MsgBox ("[导入年月]日期或格式不正确，格式必须为YYYYMMDD，年4位，月2位,日2位")
        Exit Sub
     End If
   
    '打开原文件
    PathFile = Application.GetOpenFilename("Excel File, *.xls", , "TABLE File Path")

    If PathFile = "False" Then
        MsgBox ("No file choosed")
        Exit Sub
    End If
   
    SoureFile = Mid(PathFile, InStrRev(PathFile, "\") + 1, Len(PathFile))
   
    Workbooks.Open SoureFile, 0

    Set Book1 = Workbooks(SoureFile)
    Set Sheet1a = Book1.Worksheets(SheetNO)
   
    Sheet1a.Activate
    MaxRowQty = Sheet1a.UsedRange.Rows.Count
    ActiveWindow.WindowState = xlMinimized
   
   
    '新建一个空白文件
    Set Book2 = Workbooks.Add
    Set Sheet2a = Book2.Worksheets(1)
    Sheet2a.Activate
    ActiveWindow.WindowState = xlMinimized
  
     
    For I = 0 To MonthQty - 1
        'Set RangeData = Union(Sheet1a.Range(RangePoint1 & RangePoint3).Resize(MaxRowQty, 3), Sheet1a.Range(RangePoint2 & RangePoint3).Resize(MaxRowQty, ColQty))
        Sheet1a.Range(RangePoint1 & RangePoint3).Resize(MaxRowQty, 3).Copy
        Sheet2a.Range("H1").Offset(I * MaxRowQty, 0).PasteSpecial Paste:=xlPasteValues
       
        Sheet1a.Range(RangePoint2 & RangePoint3).Offset(0, ColQty * I).Resize(MaxRowQty, ColQty).Copy
        Sheet2a.Range("K1").Offset(I * MaxRowQty, 0).PasteSpecial Paste:=xlPasteValues
        'Selection.NumberFormatLocal = "0.00_ "
       
        Sheet2a.Range("A1").Offset(I * MaxRowQty, 0).Resize(MaxRowQty, 1) = TargetMonth
        Sheet2a.Range("B1").Offset(I * MaxRowQty, 0).Resize(MaxRowQty, 1) = Version
        Sheet2a.Range("C1").Offset(I * MaxRowQty, 0).Resize(MaxRowQty, 1) = SubVersion
        Sheet2a.Range("D1").Offset(I * MaxRowQty, 0).Resize(MaxRowQty, 1) = PublishDate
        Sheet2a.Range("E1").Offset(I * MaxRowQty, 0).Resize(MaxRowQty, 1) = Category
        Sheet2a.Range("F1").Offset(I * MaxRowQty, 0).Resize(MaxRowQty, 1) = SubCategory
        Sheet2a.Range("G1").Offset(I * MaxRowQty, 0).Resize(MaxRowQty, 1) = GetProdMonth(ProdMonth, I)

     Next I
   
   Book1.Close SaveChanges:=False

   
    '填充工场编号
    Site = ""
    For I = 1 To MaxRowQty * MonthQty
        If Sheet2a.Range("H" & I) <> "" Then
            Site = Trim(Replace(Sheet2a.Range("H" & I), " ", ""))  '清除空格
        End If
        If Site = "SSHQ" Then
            Site = "OPT"
        End If
               
        Sheet2a.Range("H" & I) = Site
    Next I
   
  
    Sheet2a.Activate ' 没有这句话，以下的Row.select 将会出错
   
    '删除机种编号为空的行
   
    I = MaxRowQty * MonthQty
    Do While I > 0
        ModelCode = Sheet2a.Range("I" & I)
        ModelCode = Trim(ModelCode)
        If ModelCode = "" Then
           Sheet2a.Rows(I).Select
           Selection.Delete Shift:=xlUp
        End If
        I = I - 1
    Loop
  
    ActiveWindow.WindowState = xlNormal
   
End Sub

 

Function GetProdMonth(ProdMonth As String, MonthOffset As Integer) As String
    Dim riqi As String
   
    riqi = ProdMonth & "01"
    riqi = Format(riqi, "####/##/##")
    riqi = DateAdd("m", MonthOffset, riqi)
    riqi = Format(riqi, "yyyymm")
   
    GetProdMonth = riqi

End Function