CODEWITHSUNDEEP
vbaexcel
shilohln
shilohln

Reputation: 81

VBA Excel DO WHILE skipped, unsure why

I wrote an Excel macro, shown below, using some sample code from "Excel, loop through XLSM files and copy row to another sheet". It should loop through some .xlsm files in the same folder as ThisWorkbook, pulling everything from Columns C, D and E in a sheet named "Summary2" from each .xlsm file. Those should get copied into Columns C, D and E of ThisWorkbook, and the filename of each file in the folder should appear beside (in Col B) the data that accompanies it. 

Sub Summarize()

Dim SummaryWkb As Workbook, SourceWkb As Workbook
Dim SummarySheet As Worksheet, SourceWks As Worksheet
Dim FolderPath As String
Dim FileName As Variant
Dim NRow As Long
Dim LRow As Long
Dim LastRow As Long

Set SummaryWkb = ThisWorkbook
Set SummarySheet = SummaryWkb.Worksheets(1)

SummarySheet.Name = "Summary"

FolderPath = SummaryWkb.Path
FileName = Dir(FolderPath)


NRow = 2
Do While (FileName <> "")

    Set SourceWkb = Workbooks.Open(FolderPath & FileName)
    Set SourceWks = SourceWkb.Sheets("Summary2")

    'File Name Copy
    SummarySheet.Range("B" & NRow) = FileName
    NRow = NRow

    'Data Copy
    LastRow = SourceWks.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

    LRow = NRow + LastRow

    SourceWks.Range("C2:C" & LastRow).Copy
    SummarySheet.Range("C" & NRow & ":C" & LRow).PasteSpecial xlPasteValues

    SourceWks.Range("D2:D" & LastRow).Copy
    SummarySheet.Range("D" & NRow & ":D" & LRow).PasteSpecial xlPasteValues

    SourceWks.Range("E2:E" & LastRow).Copy
    SummarySheet.Range("E" & NRow & ":D" & LRow).PasteSpecial xlPasteValues

    SourceWkb.Close False
    NRow = NRow + LastRow + 1

FileName = Dir()
Loop

SummarySheet.Range("B1") = "Source"
SummarySheet.Range("C1") = "Machine"
SummarySheet.Range("D1") = "Quantity"
SummarySheet.Range("E1") = "Ranking"

SummarySheet.Columns.AutoFit
SummaryWkb.Save


MsgBox "Summary Successfully Created!", vbInformation

Set SourceWkb = Nothing
Set SourceWks = Nothing
Set SummarySheet = Nothing
Set SummaryWkb = Nothing

End Sub

When I run this macro the do while loop gets skipped and I have no idea why. Also, if there is a better way of copying and pasting all of the cells in one go I'd be happy to hear of it.

Upvotes: 0

Views: 113

Answers (1)

Doug Coats
Doug Coats

Reputation: 7107

try this with your do while

 path = "path2folder" & "\"  
  Filename = Dir(path & "*.xl??")

  Do While Len(Filename) > 0
      DoEvents
      Set wbk = Workbooks.Open(path & Filename, True, True)
           'add your code
      wbk.Close False
      Filename = Dir
 Loop

If you want to do everything in one go, you need to fill an array and then dump contents of an array into new worksheet. Doing it one at a time like you have will take forever if you searching through lots of workbooks.

Also instead of copy & pasting you can just say NewCell.value = OldCell.Value

Upvotes: 1

Related Questions