Új hozzászólás Aktív témák

• #14587 lappy őstag Oly #14579

  Új Válasz 2012-08-09 07:47:31 #14587

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  lappy

  őstag

  válasz Oly #14579 üzenetére

  Private Declare Function SetCurrentDirectoryA Lib _
  "kernel32" (ByVal lpPathName As String) As Long
  
  Sub ChDirNet(szPath As String)
  SetCurrentDirectoryA szPath
  End Sub
  
  Sub Combine_Workbooks_Select_Files()
  Dim MyPath As String
  Dim SourceRcount As Long, Fnum As Long
  Dim mybook As Workbook, BaseWks As Worksheet
  Dim sourceRange As Range, destrange As Range
  Dim rnum As Long, CalcMode As Long
  Dim SaveDriveDir As String
  Dim FName As Variant
  
  With Application
  CalcMode = .Calculation
  .Calculation = xlCalculationManual
  .ScreenUpdating = False
  .EnableEvents = False
  End With
  
  SaveDriveDir = CurDir
  ChDirNet "C:\"
  
  FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
  MultiSelect:=True)
  If IsArray(FName) Then
  Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  rnum = 1
  For Fnum = LBound(FName) To UBound(FName)
  Set mybook = Nothing
  On Error Resume Next
  Set mybook = Workbooks.Open(FName(Fnum))
  On Error GoTo 0
  If Not mybook Is Nothing Then
  On Error Resume Next
  With mybook.Worksheets(1)
  Set sourceRange = .Range("A1:A25")
  End With
  If Err.Number > 0 Then
  Err.Clear
  Set sourceRange = Nothing
  Else
  If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
  Set sourceRange = Nothing
  End If
  End If
  On Error GoTo 0
  
  If Not sourceRange Is Nothing Then
  
  SourceRcount = sourceRange.Rows.Count
  
  If rnum + SourceRcount >= BaseWks.Rows.Count Then
  MsgBox "Not enough rows in the sheet. "
  BaseWks.Columns.AutoFit
  mybook.Close savechanges:=False
  GoTo ExitTheSub
  Else
  Set destrange = BaseWks.Range("A" & rnum)
  With sourceRange
  Set destrange = destrange. _
  Resize(.Rows.Count, .Columns.Count)
  End With
  destrange.Value = sourceRange.Value
  
  rnum = rnum + SourceRcount
  End If
  End If
  mybook.Close savechanges:=False
  End If
  Next Fnum
  BaseWks.Columns.AutoFit
  End If
  ExitTheSub:
  With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalcMode
  End With
  ChDirNet SaveDriveDir
  End Sub

Új hozzászólás Aktív témák