Good bosses, I searched the Internet, a piece of code is used to merge multiple EXCEL workbook don't work for the same workbook multiple tables, the first table input code completely normal, achieve the effect, but in the second table input code displayed when the subscript crossing the line, I completely white in this respect, the code is the search on the net, because is a large amount of tables, so I do not know how to start, hope everybody who help me to solve it, this is part of the form and code of baidu network backup link, link: https://pan.baidu.com/s/19fmnTObzB6XoAcEhjV042w extracted code: iu4c
If the bosses don't want to link, which is the code capture
This screenshot is form, a total of 62 such form

CodePudding user response:

Looked at it, because you want to copy the files in the macro code, but also a open operation, subscript subscript crossing the line crossing the line is not the current code, but the file where the subscript crossing the line is

CodePudding user response:

Look, this is you 52-2. XLS in code,

CodePudding user response:

I'm curious how you two are the wrong into unused,

CodePudding user response:

Finally finished?

CodePudding user response:

Miss sun code try


Sub CollectWorkBookDatas ()
Dim shtActive As Worksheet, RNG As Range, shtData As Worksheet
Dim nTitleRow As Long, k As Long, nLastRow As Long
Dim As Long, I j As Long, nStartRow As Long
Dim aData, As aResult, nStarRng Long
Dim strPath As String, strFileName As String
Dim strKey As String, nShtCount As Long
With the Application. The FileDialog (msoFileDialogFolderPicker)
'get the user to select the folder path
If the Show Then strPath=. SelectedItems (1) the Else Exit Sub
End With
If Right (strPath, 1) & lt;> "" Then strPath=strPath & amp; ""
StrKey=InputBox (" please enter the need to merge the keywords worksheet contains: "& amp; VbCrLf & amp; "If not fill in the keywords, the default summary all table data", "remind")
If StrPtr (strKey)=0 Then the Exit Sub 'If click cancel or close button, Then Exit the program
NTitleRow=Val (InputBox (" please enter the title of the number of rows, the default title rows to 1 ", "alert", 1))
If nTitleRow & lt; 0 Then MsgBox "title rows cannot be negative,", 64, "warning" : the Exit Sub
The Set shtActive=ActiveSheet
With the Application
. ScreenUpdating=False
. DisplayAlerts=False
. AskToUpdateLinks=False
End With
ReDim aResult (1 To 80000, 1 To 1) 'statement the result array
To empty the current table data Cells. ClearContents'
Cells. The NumberFormat="@" 'set the cell to text format
StrFileName=Dir (strPath & amp; * "" *. XLS) 'use the Dir function traversal excel file
The Do While strFileName & lt;> "
"If strFileName & lt;> ThisWorkbook. A file Name Then 'to avoid repeated open error
With GetObject (strPath & amp; StrFileName)
'to read' form to read a file, use the getobject than workbooks. Open slightly faster
For Each shtData In. Worksheets' traverse table
If InStr (1, shtData. Name, strKey, vbTextCompare) Then
'if the table contains the keyword is aggregated (not distinguish keywords letter case)
The Set of RNG=shtData. UsedRange
If RNG. Count & gt; Table 1 Then 'judgment whether or not it's data...
NShtCount=nShtCount + 1 'summary the number of working table
NStartRow=IIf (nShtCount=1, 1, nTitleRow + 1) 'to determine whether a traverse data source should be deducted header row
AData reads the data area array arr=https://bbs.csdn.net/topics/rng.Value '
If UBound (aData, 2) + 2 & gt; UBound (aResult, 2) Then 'dynamic adjustment results array maximum number of columns to BRR
ReDim Preserve aResult (1 To UBound (aResult), 1 To UBound (aData, 2) + 2)
End the If
For I=nStartRow To UBound (aData) 'traverse line
K=k + 1
AResult (k, 1)=put workbook strFileName 'array in the first column name
AResult (k, 2)=shtData. The Name 'array, the second column work table Name
For j=1 To UBound (aData, 2) 'traversal column
AResult (k, j + 2)=aData (I, j)
Next
If k & gt; Then UBound (aResult) - 1
'if the data lines to reach the limit of the result array, the data in the summary table, and clear the result array
With shtActive
NLastRow=. Cells (Rows. The Count, 1). The End (xlUp). Row 'access to the location of the source data placed
If nLastRow=1 Then 'determine whether deduct header row
NStarRng=IIf (nTitleRow=0, 1, 0)
Range (" a1 "). Offset (nStarRng). The Resize (k, UBound (aResult, 2))=aResult
Range (" a1, b1)=Array (" source workbook name ", "source of work table name")
'the first two columns to put source workbook and work table name
The Else
Range (" a1 "). Offset (nLastRow). The Resize (k, UBound (aResult, 2))=aResult
Put the result array data
'End the If
End With
K=0
ReDim aResult (1 To UBound (aResult), 1 To UBound (aResult, 2))
'to reset the result array
End the If
Next
End the If
End the If
Next
. Close False 'Close the workbook
End With
End the If
StrFileName=Dir 'next excel file
Loop
If k & gt; 0 Then
ShtActive. Select 'activation summary table
NLastRow=Cells (Rows) Count, 1.) the End (xlUp). Place the location of the data Row '
If nLastRow=1 Then 'If the summary table data is empty, need to collect the data of no more than the result array limit
NStarRng=IIf (nTitleRow=0, 1, 0)
Range (" a1 "). Offset (nStarRng). The Resize (k, UBound (aResult, 2))=aResult
Range (" a1, b1)=Array (" source workbook name ", "source of work table name")
The Else
Range (" a1 "). Offset (nLastRow). The Resize (k, UBound (aResult, 2))=aResult
End the If
End the If
With the Application
. ScreenUpdating=True
. DisplayAlerts=True
. AskToUpdateLinks=True
End With
MsgBox "total summary is complete," & amp; NShtCount & amp; "A work table", and "xing-hua sun
"End Sub