VBA- running loop wihin another loop

[flashjas]

Hi guys,

I have a problem. I need to copy some 500 files into one. I think I have to do two loops. First loop is correct I guess, I just open and select these files. I have a problem doing second loop. The problem is that the sheet I want to copy changes name every time, but dont know how to do it. The good news is that these sheets have partially same name. The problem is that I dont know how to combine these two loops together.

Will be grateful for your help!

My code:

Sub zboze()


Dim MyObj As Object, MySource As Object, file As Variant, arkusz As Worksheet
file = Dir("C:\Users\Jaś\Desktop\ROLNICTWO\ROLNICTWO\ZBOŻA\")

While (file <> "")

If (Mid(file, 5, 4) & "-" & Mid(file, 10, 2) & "-" & Mid(file, 13, 2)) > CDate("2005-01-01") Then

Workbooks.Open ("C:\Users\Jaś\Desktop\ROLNICTWO\ROLNICTWO\ZBOŻA\" & file)
Windows(file).Activate
If arkusz.Name Like "*Zmiana Roczna*" Then
arkusz.Activate
Range("C7:C16").Select
Selection.Copy
Windows("zboze_dane").Activate
Range("B1").End(xlDown).Offset(1, 0).PasteSpecial Transpose:=True
Range("A1").End(xlDown).Offset(1, 0).Select
Selection.Value = Mid(file, 5, 10)
ActiveCell.Replace What:=".", Replacement:="-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False


Windows(file).Close False
End If
file = Dir
Wend
End Sub

 

[WarPigl3t]

Its hard to read your code when you didn't put it in code brackets so I did it for you so I can see your code properly.

Sub zboze()
     Dim MyObj As Object, MySource As Object, file As Variant, arkusz As Worksheet
     file = Dir("C:\Users\Jaś\Desktop\ROLNICTWO\ROLNICTWO\ZBOŻA\")
     While (file <> "")
          If (Mid(file, 5, 4) & "-" & Mid(file, 10, 2) & "-" & Mid(file, 13, 2)) > CDate("2005-01-01") Then
               Workbooks.Open ("C:\Users\Jaś\Desktop\ROLNICTWO\ROLNICTWO\ZBOŻA\" & file)
               Windows(file).Activate
               If arkusz.Name Like "*Zmiana Roczna*" Then
                    arkusz.Activate
                    Range("C7:C16").Select
                    Selection.Copy 
                    Windows("zboze_dane").Activate
                    Range("B1").End(xlDown).Offset(1, 0).PasteSpecial Transpose:=True
                    Range("A1").End(xlDown).Offset(1, 0).Select
                    Selection.Value = Mid(file, 5, 10)
                    ActiveCell.Replace What:=".", Replacement:="-", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False


               Windows(file).Close False
          End If
          file = Dir 
     Wend
End Sub

You are missing an "End If". Please correct this issue. And use code brackets like this [code!] and [/code!] but without the "!". I only added it so this forum doesn't confuse it as real code otherwise you wouldn't see it.

 

[WarPigl3t]

Once you post your code in code brackets and correct the End If issue, please explain what you mean in your first post. I find it easiest to understand what you want the code to do by explaining what you would do if you had to do your task manually.

 

[JackDanIce]

Welcome to the board, maybe this?

Sub zboze_v1()

    Dim obj         As Object
    Dim mySrc       As Object
    Dim file        As Variant
    Dim wkbDest     As Workbook
    Dim wkb         As Workbook
    Dim wks         As Worksheet
    Dim wksSrc      As Worksheet
    Dim arr()       As Variant
    
    Const strRoot   As String = "C:\Users\Jas\Desktop\ROLNICTWO\ROLNICTWO\ZBOZA\"
    Const strSheet  As String = "*Zmiana Roczna*"
    
    file = Dir("C:\Users\Jas\Desktop\ROLNICTWO\ROLNICTWO\ZBOZA\")
    Set wkbDest = Workbooks("zboze_dane.xlsm")
        
    Application.ScreenUpdating = False
        
    While file <> vbNullString
        Set wkb = Workbooks.Open(strRoot & file)
        
        With wkb
        
            On Error Resume Next
            For Each wks In .Worksheets
                If wks.Name Like strSheet Then
                    Set wksSrc = wks
                    Exit For
                End If
            Next wks
            On Error GoTo 0
            
            If Not wksSrc Is Nothing Then
                arr = wksSrc.Range("C7:C16").Value
                With wkbDest.ActiveSheet
                    .Cells(.Rows.Count, 2).End(xlUp).Offset(1).Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
                    .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value = Replace(Mid(file, 5, 10), ".", "-")
                End With
                Erase arr
                Set wksSrc = Nothing
            Else
                MsgBox "Sheet with name like: " & strSheet & " not found in workbook: " & wkb.Name, vbExclamation, "Sheet Not Found"
            End If
            
            .Close False
        End With
        
        Set wkb = Nothing
        
        file = Dir
    Wend
                    
    Set wkbDest = Nothing
    
    Application.ScreenUpdating = True
    
End Sub

 

[flashjas]

Thank you guys for your reply !

Ok, first I have a lot of files named like this: zbo_2005.01.01 and so on….. But that is first part of my code and it is done correctly by me. This code is below.
Sub zboze() Dim MyObj As Object, MySource As Object, file As Variant file = Dir("C:\Users\Jaś\Desktop\ROLNICTWO\ROLNICTWO\ZBOŻA\") While (file <> "") If (Mid(file, 5, 4) & "-" & Mid(file, 10, 2) & "-" & Mid(file, 13, 2)) > CDate("2005-01-01") Then Workbooks.Open ("C:\Users\Jaś\Desktop\ROLNICTWO\ROLNICTWO\ZBOŻA\" & file) Windows(file).ActivateRange("C7:C16").Select Selection.Copy Windows("zboze_dane").Activate Range("B1").End(xlDown).Offset(1, 0).PasteSpecial Transpose:=True Range("A1").End(xlDown).Offset(1, 0).Select Selection.Value = Mid(file, 5, 10) ActiveCell.Replace What:=".", Replacement:="-", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ReplaceFormat:=False Windows(file).Close False End If file = Dir WendEnd Sub

The problem is how to activate those sheets with changing names and how to include this part in this code written above. When VBA opens my file I want it to activate one sheet from each file and to copy some data from this sheet. This sheet changes name. The first file’s sheet is called Zmiana Roczna 01_05 next Zmiana Roczna 02_05 and so on.
BTW. When I added another End If, there was still some problem.

Will appreciate further comments!

 

[flashjas]

Thank you guys for your reply !

Ok, first I have a lot of files named like this: zbo_2005.01.01 and so on….. But that is first part of my code and it is done correctly by me. This code is below.

Code:

Sub zboze() Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("C:\Users\Jaś\Desktop\ROLNICTWO\ROLNICTWO\ZBOŻA\")

While (file <> "")

If (Mid(file, 5, 4) & "-" & Mid(file, 10, 2) & "-" & Mid(file, 13, 2)) > CDate("2005-01-01") Then
Workbooks.Open ("C:\Users\Jaś\Desktop\ROLNICTWO\ROLNICTWO\ZBOŻA\" & file)
Windows(file).Activate
Range("C7:C16").Select
Selection.Copy

Windows("zboze_dane").Activate

Range("B1").End(xlDown).Offset(1, 0).PasteSpecial Transpose:=True
Range("A1").End(xlDown).Offset(1, 0).Select Selection.Value = Mid(file, 5, 10) ActiveCell.Replace What:=".", Replacement:="-", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ReplaceFormat:=False

Windows(file).Close False
End If
file = Dir
Wend
End Sub

The problem is how to activate those sheets with changing names and how to include this part in this code written above. When VBA opens my file I want it to activate one sheet from each file and to copy some data from this sheet. This sheet changes name. The first file’s sheet is called Zmiana Roczna 01_05 next Zmiana Roczna 02_05 and so on.
When I added another End If, there was still some problem.

Will appreciate further comments!

 

[flashjas]

Sub zboze() Dim MyObj As Object, MySource As Object, file As Variant file = Dir("C:\Users\Jaś\Desktop\ROLNICTWO\ROLNICTWO\ZBOŻA\") While (file <> "") If (Mid(file, 5, 4) & "-" & Mid(file, 10, 2) & "-" & Mid(file, 13, 2)) > CDate("2005-01-01") Then Workbooks.Open ("C:\Users\Jaś\Desktop\ROLNICTWO\ROLNICTWO\ZBOŻA\" & file) Windows(file).ActivateRange("C7:C16").Select Selection.Copy Windows("zboze_dane").Activate Range("B1").End(xlDown).Offset(1, 0).PasteSpecial Transpose:=True Range("A1").End(xlDown).Offset(1, 0).Select Selection.Value = Mid(file, 5, 10) ActiveCell.Replace What:=".", Replacement:="-", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ReplaceFormat:=False Windows(file).Close False End If file = Dir WendEnd Sub
</pre>

 

[flashjas]

Sorry guys, dont know why I cant save this code properly...

 

[JackDanIce]

Have you tried the code I suggested? If so, what happened?

 

[flashjas]

Yeah sure, but unfortunately it doesnt work...