Looping in a loop (I think)

  • I'm starter with VBA and have managed to complete below code with some help, but have one last task to figure out for making the code as I want it to do. I want to apply below code on a folder with several *.txt files. The code works well but I need to manually move files to different folders and run the code. So to make it more automated I need to do some improvements which I hope I can get some suggestion on.

    I have let say 40 *.xls files in the folder, I have also a *.xlsm file with eight sheets named (PC2,4,6...-16) in the same folder; I want to copy the column E from the first *.xls file to the "joined_test.xlsm" sheet PC2(sheet1) column B, then copy column E from *.xls file 2 to "joined_test.xlsm" sheet PC4(sheet2) column B and do this until file 8 column E is copied to sheet PC16(sheet8) column B. Then copy column E from file 9 to "joined_test.xlsm" sheet PC2(sheet1) column C and so on until 8 sheets five columns on each sheet is populated with values from the *.xls files.

    Different way to achieve the same result would be to do this instead: From *.xls file 1 copy column E to "joined_test.xlsm" sheet PC2 (sheet1) column B, then open *.xls file 9 and copy column E to "joined_test.xlsm" sheet PC2(sheet1) column C and so on until 8 columns are populated with values in sheet PC2(sheet1). Then select *.xls file 2 copy column E to "joined_test.xlsm" sheet PC4(sheet2) column B, then copy column E from *.xls file 10 to sheet PC4(sheet2) column C and so on.

    So to keep the column the same and change sheet for every new open *.xls file or to keep the same sheet and change column for every new open *.xls file, the result of both should be the same.

    I guess I need to have some kind of loop in the loop solution, but not really sure how to do it. I appreciate all the help. (I have change the size of the part in the code which I think need to be improved)

    Sub Macro8()'' Macro8 Macro'' Keyboard Shortcut: Ctrl+d'Dim MyFolder As String Dim myfile As String Dim folderName As String Dim c As Long Dim k As Long c = 2 k = 2 With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False If .Show = -1 Then folderName = .SelectedItems(1) End If End With myfile = Dir(folderName & "\*.txt")  Do While myfile <> "" Workbooks.OpenText Filename:=folderName & "\" & myfile, Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _        Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1), _        TrailingMinusNumbers:=True Cells.Select    Selection.Replace What:=".", Replacement:=".", LookAt:=xlPart, _    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _    ReplaceFormat:=False        Columns("E:E").Select    Selection.FormatConditions.AddTop10    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority    With Selection.FormatConditions(1)        .TopBottom = xlTop10Top        .Rank = 1        .Percent = False    End With    With Selection.FormatConditions(1).Interior        .PatternColorIndex = xlAutomatic        .Color = 10498160        .TintAndShade = 0    End With    Selection.FormatConditions(1).StopIfTrue = False    ActiveWorkbook.SaveAs Filename:=folderName & "\" & Replace(myfile, ".txt", ".xlsx"), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False    Selection.Copy     [B][SIZE=14px]    'Windows("Joined_test.xlsm").Activate    Workbooks("Joined_test.xlsm").Sheets("PC" & k).Activate    Cells(1, c).EntireColumn.Select    ActiveSheet.Paste    Cells(34, c).Select    ActiveCell.FormulaR1C1 = "CC" & k    c = c + 1    k = k + 2[/SIZE][/B]          'Ensure Workbook has closed before moving on to next line of code      DoEvents    'Get next file name      myfile = Dir  Loop      For Each wb In Workbooks        If wb.Name <> ThisWorkbook.Name Then            'wb.SaveAs Filename:=Path & wb.Name            ', FileFormat:=51           wb.Close False        End If    Next wb    'ThisWorkbook.Close False    'Message Box when tasks are completed  MsgBox "Task Complete!"      ResetSettings:  'Reset Macro Optimization Settings    Application.EnableEvents = True    Application.Calculation = xlCalculationAutomatic    Application.ScreenUpdating = True End Sub[/I][I]


Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!