Sub doExcel(ByRef pathFile As String)
Dim wb As Workbook
Dim sheet_ZP, sheet_Work As Worksheet
Dim lineNo, midLongth, i, No, maxLine, typeCol, lengthCol, resultCol, startLine, logLine As Integer
Dim length, NX, retStr, startStr, endStr, midStr, itemName, MID_STR, NoStr As String
typeCol = 4
lengthCol = 16
resultCol = 20
startLine = 8
itemNameCol = 2
On Error Resume Next
Set wb = Workbooks.Open(Filename:=pathFile)
Set sheet_ZP = wb.Worksheets("挔昜崁栚")
Set sheet_Work = wb.Worksheets("WORK")
'sheet_Work.Columns("I:I").NumberFormatLocal = "@"
'max line num of sheet
'maxLine = sheet_ZP.Range("b65536").End(xlUp).Row
maxLine = 400
logLine = 1
No = 0
For lineNo = startLine To maxLine
itemName = Trim(sheet_ZP.Cells(lineNo, itemNameCol).Value)
If itemName = "" And sheet_ZP.Cells(lineNo, itemNameCol).MergeCells Then
GoTo Continue
ElseIf Not sheet_ZP.Cells(lineNo, itemNameCol).Borders(xlEdgeBottom).LineStyle = xlContinuous Then
Exit For
End If
NX = getNX(sheet_ZP, sheet_Work, itemName)
If NX = "NNNXXX" Then
Worksheets("log").Cells(logLine, 1) = pathFile
logLine = logLine + 1
End If
length = Trim(sheet_ZP.Cells(lineNo, lengthCol).Value)
No = No + 1
retStr = getRetStr(CStr(No), length, itemName, NX)
sheet_ZP.Cells(lineNo, resultCol) = retStr
Continue:
Next
wb.Save
wb.Close
End Sub
Sub test()
Dim file As String
file = "C:\1\挔昜愝寁彂_WAP0001_埗柤擖椡妋擣昜.xlsx"
Call doExcel(file)
End Sub
Sub main()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim pf As String
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
'Set objFolder = objFSO.GetFolder("C:\1\zp_work")
Set objFolder = objFSO.GetFolder("C:\1\t")
'Set objFolder = objFSO.GetFolder("C:\1\wode")
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
If InStr(1, objFile.Path, "~", 1) = False Then
pf = objFile.Path
Call doExcel(pf)
End If
Next objFile
End Sub
Sub copyWork()
Dim objFSO As Object
Dim bkFolder, desFolder As Object
Dim bkFile, desFile As Object
Dim i As Integer
Dim pf As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set bkFolder = objFSO.GetFolder("C:\1\715\bk")
Set desFolder = objFSO.GetFolder("C:\1\715\des")
For Each desFile In desFolder.Files
For Each bkFile In bkFolder.Files
If Replace(bkFile.name, "bk_", "") = desFile.name Then
Workbooks(bkFile.Path).Worksheets(5).Copy After:=Workbooks(desFile.Path).Worksheets(6)
End If
Next bkFile
Next desFile
End Sub
'C:\棲嶌嬈\pdf\0720
Sub copyWorkNG()
Dim objFSO As Object
Dim bkFolder, desFolder As Object
Dim bkFile, desFile As Object
Dim i As Integer
Dim pf As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set bkFolder = objFSO.GetFolder("C:\棲嶌嬈\pdf\0720")
Set desFolder = objFSO.GetFolder("C:\1\720")
For Each desFile In desFolder.Files
If InStr(1, desFile.Path, "~", 1) = False Then
'Workbooks("C:\1\720\2\WFP0310_幮夛暉巸朄恖尭柶妋擣徹_僠僃僢僋儕僗僩.xlsx").Worksheets("強尒0719").Copy After:=Workbooks(desFile.Path).Worksheets("WORK")
Workbooks(desFile.Path).Worksheets(2).Copy After:=Workbooks(desFile.Path).Worksheets(3)
End If
Next desFile
End Sub
Sub countWork()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim pf As String
Dim workCnt, zpCnt, iWB As Integer
Dim itemName As String
Dim wb As Workbook
Dim sheet_ZP, sheet_Work As Worksheet
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\1\BK_20160715")
iWB = 1
For Each objFile In objFolder.Files
If InStr(objFile.Path, "~") > 0 Then
GoTo conobj
End If
On Error Resume Next
Set wb = Workbooks.Open(Filename:=objFile.Path)
Application.AskToUpdateLinks = False
'ThisWorkbook.UpdateLinks = xlUpdateLinksAlways
Set sheet_ZP = wb.Worksheets("挔昜崁栚")
Set sheet_Work = wb.Worksheets("WORK")
workCnt = 0
zpCnt = 0
For lineNo = 8 To 400
itemName = Trim(sheet_ZP.Cells(lineNo, 2).Value)
If itemName = "" And sheet_ZP.Cells(lineNo, 2).MergeCells Then
GoTo ContinueZP
ElseIf Not sheet_ZP.Cells(lineNo, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous Then
Exit For
End If
zpCnt = zpCnt + 1
ContinueZP:
Next
lineNo = 0
For lineNo = 4 To 400
itemName = Trim(sheet_Work.Cells(lineNo, 1).Value)
If itemName = "" Then
Exit For
End If
workCnt = workCnt + 1
Next
iWB = iWB + 1
Workbooks("vba_0001.xlsm").Worksheets("log").Cells(iWB, 1) = objFile.name
Workbooks("vba_0001.xlsm").Worksheets("log").Cells(iWB, 2) = zpCnt
Workbooks("vba_0001.xlsm").Worksheets("log").Cells(iWB, 3) = workCnt
wb.Close savechanges:=False
conobj:
Next objFile
End Sub
Sub skeduleSheet()
Dim wb As Workbook
Dim sheet_ZP, sheet_Work As Worksheet
Dim lineNo, midLongth, i, No, maxLine, typeCol, lengthCol, resultCol, startLine, logLine, lineD, lineS As Integer
Dim length, NX, retStr, startStr, endStr, midStr, itemName, MID_STR, NoStr, pathFile, sName, dName As String
typeCol = 4
lengthCol = 16
resultCol = 20
startLine = 8
itemNameCol = 2
pathFile = ""
On Error Resume Next
Set wb = Workbooks.Open(Filename:="C:\1\挔昜崁栚悢.xlsx")
Set sheet_d = wb.Worksheets("d")
Set sheet_s = wb.Worksheets("s")
'sheet_Work.Columns("I:I").NumberFormatLocal = "@"
'max line num of sheet
'maxLine = sheet_ZP.Range("b65536").End(xlUp).Row
maxLine = 400
logLine = 1
No = 0
For lineD = 1 To maxLine
dName = Trim(sheet_d.Cells(lineD, 2).Value)
For lineS = 2 To maxLine
sName = Trim(sheet_s.Cells(lineS, 1).Value)
If InStr(sName, dName) > 0 Then
sheet_d.Cells(lineD, 7) = sheet_s.Cells(lineS, 2).Value
sheet_d.Cells(lineD, 8) = sheet_s.Cells(lineS, 3).Value
End If
Next
Next
End Sub
'
Function getNX(sheet_ZP, sheet_Work As Worksheet, ByVal val As String) As String
If val = "埗柤廧強丂奜帤" Then
MsgBox "埗柤廧強丂奜帤侾"
End If
Dim maxLine_sheet_ZP, maxLine_sheet_Work, startZp, startWork, iZP, iWork, iIsX As Integer
Dim itemName_Work, ret, zhaiYaoNX As String
maxLine_sheet_Work = sheet_Work.Range("b65536").End(xlUp).Row
startZp = 8
startWork = 4
val = removeDig(val)
getNX = "N"
If InStr(1, val, "揈梫", 1) Then
For iWork = startZp To maxLine_sheet_Work
itemName_Work = Trim(sheet_Work.Cells(iWork, 1).Value)
itemName_Work = removeDig(itemName_Work)
If InStr(1, itemName_Work, "揈梫", 1) Then
zhaiYaoNX = zhaiYaoNX + Trim(sheet_Work.Cells(iWork, 4).Value)
End If
Next
If InStr(1, zhaiYaoNX, "N", 1) And InStr(1, zhaiYaoNX, "X", 1) Then
getNX = "NNNXXX"
ElseIf InStr(1, zhaiYaoNX, "X", 1) Then
getNX = "X"
ElseIf InStr(1, zhaiYaoNX, "N", 1) Then
getNX = "N"
End If
Else
For iWork = startZp To maxLine_sheet_Work
itemName_Work = Trim(sheet_Work.Cells(iWork, 1).Value)
itemName_Work = removeDig(itemName_Work)
If InStr(1, val, itemName_Work, 1) Or InStr(1, itemName_Work, val, 1) Then
NX = Trim(sheet_Work.Cells(iWork, 4).Value)
If NX = "X" Then
getNX = "X"
Exit For
End If
End If
Next
End If
End Function
'暥帤楍偵悢帤傪嶍彍偡傞
Function removeDig(ByVal val As String) As String
Dim re
Set re = CreateObject("VBScript.RegExp")
' 惓婯昞尰僷僞乕儞傪僙僢僩
re.pattern = "[侽-俋|0-9]+"
' 戞堦堷悢偑抲姺懳徾偺暥帤楍丄戞擇堷悢偑抲姺暥帤楍
removeDig = re.Replace(val, "")
End Function
Function getRetStr(ByVal No As String, ByVal length As String, ByVal itemName As String, ByVal NX As String) As String
Dim NoStr, retStr, midStr, endStr, MID_STR As String
NoStr = Trim(str(No))
retStr = ""
endStr = ">"
midStr = ""
MID_STR = "?
midLongth = length - 1 - Len(No)
For i = 1 To midLongth
midStr = midStr & MID_STR
Next
If midLongth < 0 Then
endStr = ""
End If
retStr = NoStr & midStr & endStr
If itemName = "埗柤廧強丂奜帤" Then
MsgBox "埗柤廧強丂奜帤"
End If
If (midLongth < 0 And CInt(length) <= Len(NoStr)) Then
If NX = "N" Then
retStr = Left(itemName, length)
Else
retStr = Left("构构构", length)
End If
End If
If NX = "N" Then
retStr = StrConv(retStr, vbWide)
End If
getRetStr = retStr
End Function
