I have been editing/writing this code to merge multiple workbooks into one. However I get a "Loop without Do" compile error. The possible duplicate does not say what went wrong, only gives a new code, so that is not a answer to my question but a solution.
Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long
Dim OCol As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRangeCult As Range
Dim DestRangeCult As Range
Dim SourceRangeYield As Range
Dim DestRangeYield As Range
Dim SourceRangeLoc As Range
Dim DestRangeLoc As Range
Dim SourceRangeDRipe As Range
Dim DestRangeDRipe As Range
Dim LastRow As Integer
Dim LastColumn As Integer
Dim col As Integer
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
FolderPath = "M:\My Documents\MSC Thesis\United Kingdom\Winter Barley\Merge excel\"
NRow = 1
OCol = 2
OColD = OCol + 48
FileName = Dir(FolderPath & "*.xl*")
Do While FileName <> ""
Set WorkBk = Workbooks.Open(FolderPath & FileName)
SummarySheet.Range("A" & NRow).Value = FileName
LastRow = ActiveSheet.UsedRange.Rows.Count
LastColumn = ActiveSheet.UsedRange.Columns.Count
For col = 2 To 49
Set SourceRangeLoc = WorkBk.Worksheets(1).Range("A1:A" & LastRow)
Set DestRangeLoc = SummarySheet.Range("C" & NRow)
Set DestRangeLoc = DestRange.Resize(SourceRangeLoc.Rows.Count, 1)
Set SourceRangeCult = WorkBk.Worksheets(1).Range(OCol & "1:" & OCol & "1")
Set DestRangeCult = SummarySheet.Range("B" & NRow)
Set DestRangeCult = DestRange.Resize(SourceRangeLoc.Rows.Count, 1)
Set SourceRangeYield = WorkBk.Worksheets(1).Range(OCol & "2:" & OCol & LastRow)
Set DestRangeYield = SummarySheet.Range("D" & NRow)
Set DestRangeYield = DestRange.Resize(SourceRangeLoc.Rows.Count, 1)
Set SourceRangeDRipe = WorkBk.Worksheets(1).Range(OColD & "2:" & OColD & LastRow)
Set DestRangeDRipe = SummarySheet.Range("E" & NRow)
Set DestRangeDRipe = DestRange.Resize(SourceRangeLoc.Rows.Count, 1)
DestRangeCult.Value = SourceRangeCult.Value
Exit For
NRow = NRow + DestRange.Rows.Count
OCol = OCol + 1
WorkBk.Close savechanges:=False
FileName = Dir()
Loop
SummarySheet.Columns.AutoFit
End Sub
Aucun commentaire:
Enregistrer un commentaire