excel遍歷文件夾

❶ vba讀取excel遍歷文件指定數據

Excel文件格式一致，匯總求和，其他需求自行變通容
匯總使用了字典

Public d
Sub 按鈕1_Click()
Application.ScreenUpdating = False
ActiveSheet.UsedRange.ClearContents
Cells(1, 1) = "編號"
Cells(1, 2) = "數量"
Set d = CreateObject("scripting.dictionary")
Getfd (ThisWorkbook.Path) 'ThisWorkbook.Path是當前代碼文件所在路徑，路徑名可以根據需求修改
Application.ScreenUpdating = True
If d.Count > 0 Then
ThisWorkbook.Sheets(1).[a2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
ThisWorkbook.Sheets(1).[b2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
End If
End Sub
Sub Getfd(ByVal pth)

Set Fso = CreateObject("scripting.filesystemobject")
Set ff = Fso.getfolder(pth)
For Each f In ff.Files
Rem 具體提取哪類文件，還是需要根據文件擴展名進行處理
If InStr(Split(f.Name, ".")(UBound(Split(f.Name, "."))), "xl") > 0 Then
If f.Name <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(f)
For Each sht In wb.Sheets
If WorksheetFunction.CountA(sht.UsedRange) > 1 Then
arr = sht.UsedRange
For j = 2 To UBound(arr)
d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)
Next j
End If
Next sht
wb.Close False
End If
End If
Next f
For Each fd In ff.subfolders
Getfd (fd)
Next fd
End Sub

❷ 如何用excel vba按關鍵字選擇性的遍歷文件夾搜索文件

Excel怎樣批量提取文件夾和子文件夾所有文件

❸ EXCEL vba 讀取指定文件夾的名字和循環打開文件夾

'------------------------------------------------------------------------------

'

'FormCode

'

'------------------------------------------------------------------------------

OptionExplicit

PrivaterowAsInteger,colAsInteger

PrivateSubCloseWindows_Click()

IfTextStartRow.Text=""ThenTextStartRow=0

IfTextStartCol=""ThenTextStartCol=0

IfTextPath=""ThenTextPath="D:"

CloseMyDialogTextStartRow,TextStartCol

EndSub

PrivateSubGetDir_Click()

IfTextStartRow.Text=""ThenTextStartRow=0

IfTextStartCol=""ThenTextStartCol=0

IfTextPath=""Then

TextPath="D:"

ElseIfRight(TextPath,1)<>""Then

TextPath=TextPath&""

EndIf

doGetDirTextPath,Val(TextStartRow),Val(TextStartCol)

EndSub

PrivateSubShowWindows_Click()

IfTextStartRow.Text=""ThenTextStartRow=0

IfTextStartCol=""ThenTextStartCol=0

IfTextPath=""ThenTextPath="D:"

ShowMyDialogApplication.hWnd,TextStartRow,TextStartCol

EndSub

上面是Form上面的

OptionExplicit

DimMyFile,Mypath,MyName

Dimi%,j%

DimDirPath()AsString

SubGetDir(ByValMypathAsString,rowAsInteger,colAsInteger)

'顯示C:目錄下的名稱。

'MyPath="d:電大"'指定路徑。

MyName=Dir(Mypath,vbDirectory)'找尋第一項。

DoWhileMyName<>""'開始循環。

'跳過當前的目錄及上層目錄。

IfMyName<>"."AndMyName<>".."Then

'使用位比較來確定MyName代表一目錄。

If(GetAttr(Mypath&MyName)AndvbDirectory)=vbDirectoryThen

Cells(row+i,col)=Mypath&MyName'如果它是一個目錄，將其名稱顯示出來。

ReDimPreserveDirPath(i)

DirPath(i)=Mypath&MyName&""

i=i+1

EndIf

EndIf

MyName=Dir'查找下一個目錄。

Loop

EndSub

PublicSubdoGetDir(ByValTextPath$,ByValTextStartRow%,ByValTextStartCol%)

j=1

i=1

Mypath=TextPath

GetDirMypath,TextStartRow,TextStartCol

Forj=1Toi-1

GetDirDirPath(j),TextStartRow,TextStartCol

Next

EndSub

'endcode---------------------------------------------------

OptionExplicit

PublicConstOFN_ALLOWMULTISELECTAsLong=&H200

PublicConstOFN_CREATEPROMPTAsLong=&H2000

PublicConstOFN_ENABLEHOOKAsLong=&H20

PublicConstOFN_ENABLETEMPLATEAsLong=&H40

PublicConstOFN_ENABLETEMPLATEHANDLEAsLong=&H80

PublicConstOFN_EXPLORERAsLong=&H80000

PublicConstOFN_EXTENSIONDIFFERENTAsLong=&H400

PublicConstOFN_FILEMUSTEXISTAsLong=&H1000

PublicConstOFN_HIDEREADONLYAsLong=&H4

PublicConstOFN_LONGNAMESAsLong=&H200000

PublicConstOFN_NOCHANGEDIRAsLong=&H8

PublicConstOFN_NODEREFERENCELINKSAsLong=&H100000

PublicConstOFN_NOLONGNAMESAsLong=&H40000

PublicConstOFN_NONETWORKBUTTONAsLong=&H20000

PublicConstOFN_NOREADONLYRETURNAsLong=&H8000&'*seecomments

PublicConstOFN_NOTESTFILECREATEAsLong=&H10000

PublicConstOFN_NOVALIDATEAsLong=&H100

PublicConstOFN_OVERWRITEPROMPTAsLong=&H2

PublicConstOFN_PATHMUSTEXISTAsLong=&H800

PublicConstOFN_READONLYAsLong=&H1

PublicConstOFN_SHAREAWAREAsLong=&H4000

PublicConstOFN_SHAREFALLTHROUGHAsLong=2

PublicConstOFN_SHAREWARNAsLong=0

PublicConstOFN_SHARENOWARNAsLong=1

PublicConstOFN_SHOWHELPAsLong=&H10

PublicConstOFS_MAXPATHNAMEAsLong=260

PublicConstOFS_FILE_OPEN_FLAGS=OFN_EXPLORER_

OrOFN_LONGNAMES_

OrOFN_CREATEPROMPT_

OrOFN_NODEREFERENCELINKS

PublicConstOFS_FILE_SAVE_FLAGS=OFN_EXPLORER_

OrOFN_LONGNAMES_

OrOFN_OVERWRITEPROMPT_

OrOFN_HIDEREADONLY

PublicTypeOPENFILENAME

nStructSizeAsLong

hWndOwnerAsLong

hInstanceAsLong

sFilterAsString

sCustomFilterAsString

nMaxCustFilterAsLong

nFilterIndexAsLong

sFileAsString

nMaxFileAsLong

sFileTitleAsString

nMaxTitleAsLong

sInitialDirAsString

sDialogTitleAsString

flagsAsLong

nFileOffsetAsInteger

nFileExtensionAsInteger

sDefFileExtAsString

nCustDataAsLong

fnHookAsLong

sTemplateNameAsString

EndType

PublicOFNAsOPENFILENAME

PublicConstWM_CLOSE=&H10

"comdlg32"_

Alias"GetOpenFileNameA"_

(pOpenfilenameAsOPENFILENAME)AsLong

"comdlg32"_

Alias"GetSaveFileNameA"_

(pOpenfilenameAsOPENFILENAME)AsLong

"kernel32"_

Alias"GetShortPathNameA"_

(ByVallpszLongPathAsString,_

ByVallpszShortPathAsString,_

ByValcchBufferAsLong)AsLong

PublicConstWM_INITDIALOG=&H110

PrivateConstSW_SHOWNORMAL=1

PublicTypeRECT

LeftAsLong

TopAsLong

RightAsLong

BottomAsLong

EndType

"user32"_

(ByValhWndAsLong)AsLong

"user32"_

Alias"SetWindowTextA"_

(ByValhWndAsLong,_

ByVallpStringAsString)AsLong

"user32"_

(ByValhWndAsLong,_

ByValxAsLong,_

ByValyAsLong,_

ByValnWidthAsLong,_

ByValnHeightAsLong,_

ByValbRepaintAsLong)AsLong

"user32"_

(ByValhWndAsLong,_

lpRectAsRECT)AsLong

"user32"_

Alias"SendMessageA"_

(ByValhWndAsLong,_

ByValwMsgAsLong,_

ByValwParamAsLong,_

lParamAsAny)AsLong

"user32"_

Alias"FindWindowA"_

(ByVallpClassNameAsLong,_

ByVallpWindowNameAsString)AsLong

PublicFunctionFARPROC(ByValpfnAsLong)AsLong

FARPROC=pfn

EndFunction

PublicFunctionOFNHookProc(ByValhWndAsLong,_

ByValuMsgAsLong,_

ByValwParamAsLong,_

ByVallParamAsLong)AsLong

DimhwndParentAsLong

DimrcAsRECT

DimnewLeftAsLong

DimnewTopAsLong

DimdlgWidthAsLong

DimdlgHeightAsLong

DimscrWidthAsLong

DimscrHeightAsLong

SelectCaseuMsg

CaseWM_INITDIALOG

hwndParent=GetParent(hWnd)

IfhwndParent<>0Then

CallGetWindowRect(hwndParent,rc)

dlgWidth=rc.Right-rc.Left

dlgHeight=rc.Bottom-rc.Top

CallMoveWindow(hwndParent,newLeft,newTop,dlgWidth,dlgHeight,True)

OFNHookProc=1

EndIf

CaseElse:

EndSelect

EndFunction

PublicSubShowFolder(hWndAsLong,Mypath$)

DimsFiltersAsString

DimposAsLong

DimbuffAsString

DimsLongnameAsString

DimsShortnameAsString

WithOFN

.nStructSize=Len(OFN)

.hWndOwner=hWnd

.sFilter=sFilters

.nFilterIndex=2

.sFile=Space$(1024)&vbNullChar&vbNullChar

.nMaxFile=Len(.sFile)

.sDefFileExt="bas"&vbNullChar&vbNullChar

.sFileTitle=vbNullChar&Space$(512)&vbNullChar&vbNullChar

.nMaxTitle=Len(OFN.sFileTitle)

.sInitialDir=Mypath&vbNullChar&vbNullChar

.sDialogTitle=Mypath&vbNullChar&vbNullChar

.flags=OFS_FILE_OPEN_FLAGSOr_

OFN_ALLOWMULTISELECTOr_

OFN_EXPLOREROr_

OFN_ENABLEHOOK

.fnHook=FARPROC(AddressOfOFNHookProc)

EndWith

GetOpenFileNameOFN

EndSub

PublicSubCloseFolder(MypathAsString)

DimhWndAsLong

hWnd=FindWindow(0,Mypath)

CallSendMessage(hWnd,WM_CLOSE,0&,ByVal0&)

EndSub

PublicSubShowMyDialog(MyhWndAsLong,TextStartRowAsInteger,TextStartColAsInteger)

Dimrow,col

Dimi

DimhWndAsLong

hWnd=MyhWnd

i=1:row=TextStartRow:col=TextStartCol

DoWhileCells(i+row,col)<>""

Shell"C:Windowsexplorer.exe"&Cells(i+row,col)

'ShowFolderhWnd,Cells(i+row,col)

'hWnd=FindWindow(0,Cells(i+row,col))

i=i+1

Loop

EndSub

PublicSubCloseMyDialog(TextStartRowAsInteger,TextStartColAsInteger)

Dimrow,col

Dimi

i=1:row=TextStartRow:col=TextStartCol

DoWhileCells(i+row,col)<>""

CloseFolderpathToName(Cells(i+row,col))

i=i+1

Loop

EndSub

PrivateFunctionpathToName(Mypath$)AsString

Dimstr()AsString

str=Split(Mypath,"")

pathToName=str(UBound(str))

EndFunction

❹ 如何用VBA遍歷指定目錄下的所有子文件夾Excel文件的所有工作表

vba麻煩點，dir最快，excelhome論壇上有大量現成代碼：

SubOpiona()'//函數實例
FileArr=FileAllArr(ThisWorkbook.Path,"*.xls",ThisWorkbook.Name,False)
Fori=0ToUBound(FileArr)
MsgBoxFileArr(i)
'SetWB=Workbooks.Open(FileArr(I))'//打開工作簿
'你的代碼
'WB.Closetrue'//保存
Next
EndSub
'*******************************************************************************************************
'功能：查找指定文件夾含子文件夾內所有文件名或文件夾名（含路徑）
'函數名：FileAllArr
'參數1：Filename需查找的文件夾名不含最後的""
'參數2：FileFilter需要過濾的文件名，可省略，默認為：[*.*]
'參數3：Liwai剔除例外的文件名，可省略，默認為：空，一般為：ThisWorkbook.Name
'參數4：Files是否只要文件夾名，可省略，默認為：FALSE
'返回值：一個字元型的數組
'使用方法：FileArr=FileAllArr(ThisWorkbook.Path,"*.xls",ThisWorkbook.Name,false)
'作者:北極狐工作室QQ：14885553
'*******************************************************************************************************
PublicFunctionFileAllArr(ByValFilenameAsString,="*.*",OptionalByValLiwaiAsString="",OptionalByValFilesAsBoolean=False)AsString()
SetDic=CreateObject("Scripting.Dictionary")'創建一個字典對象
SetDid=CreateObject("Scripting.Dictionary")
Dic.Add(Filename&""),""
i=0
DoWhilei<Dic.Count
Ke=Dic.keys'開始遍歷字典
MyName=Dir(Ke(i),vbDirectory)'查找目錄
DoWhileMyName<>""
IfMyName<>"."AndMyName<>".."Then
If(GetAttr(Ke(i)&MyName)AndvbDirectory)=vbDirectoryThen'如果是次級目錄
Dic.Add(Ke(i)&MyName&""),""'就往字典中添加這個次級目錄名作為一個條目
EndIf
EndIf
MyName=Dir'繼續遍歷尋找
Loop
i=i+1
Loop
Dimarrx()AsString
i=0
IfFiles=TrueThen'//是否只輸出文件夾名

ForEachKeInDic.keys'以查找總表所在文件夾下所有excel文件為例
ReDimPreservearrx(i)
IfKe<>Filename&""Then'//自身文件夾除外
arrx(i)=Ke
i=i+1
EndIf
Next
FileAllArr=arrx
Else
ForEachKeInDic.keys'以查找總表所在文件夾下所有excel文件為例
MyFileName=Dir(Ke&FileFilter)'過濾器：EXCEL2003為：*.xls,excel2007為：*.xlsx
DoWhileMyFileName<>""
IfMyFileName<>LiwaiThen'排除例外文件
ReDimPreservearrx(i)
arrx(i)=Ke&MyFileName
i=i+1
EndIf
MyFileName=Dir
Loop
Next
FileAllArr=arrx
EndIf
EndFunction
'****************************************************************

❺ 如何用VBA遍歷指定目錄下的所有子文件夾Excel文件的所有工作表

下面的代碼是手工碼的，不曉得有沒有問題。

subtest()
dimfasstring,mPathasstring,Wbasworkbook,ShasworkSheet
ifworkbooks.count>1thenmsgbox"關閉其他工作簿！":exitsub
mPath="D:臨時文件夾"'指定路徑，注意分層標記
f=dir(mPath&"*.xls*")
dowhilef<>""
iff<>thisworkbook.namethen
setWb=workbooks.open(mPath&f)'只讀方式打開
withWb
foreachShin.workSheets
'對工作表進行操作的代碼段，自己寫。
next
endwith
wb.close0'關閉文件
endif
f=dir'枚舉,以訪問下一個工作簿。
loop
endsub