Results 1 to 1 of 1

Thread: Adjust Macro

  1. #1
    New Lounger
    Join Date
    Apr 2014
    Posts
    1
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Adjust Macro

    Hi guys,

    I have the following macro that imports data from several input files and rearranges it in a master file.

    I want to change it so that I can use it in each of the input files, whithin the same file.
    Therefore, it should look fot the input Spreadsheet "XYZ" (this is how the raw data looks like), copy the data and rearrange it in Spreadsheet "Data" (this is how the output should look like) (see attachment)

    However, my VBA skills are rather poor, therefore I kindly ask you for your help.
    The only thing that needs to be changed is: the macro should not look for and open new files, but work within the same file.
    See the macro below.

    Thanks!

    Code:
    Sub Import()
    
    Dim ws1 As Worksheet, ws2 As Worksheet, i As Long, j As Long, lRow As Long, fName As String, wb2 As Workbook
    
    Set ws1 = ActiveSheet
        Dim LastRow As Long
        With ws1
            LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        End With
    
    
    With ws1
    
        .Range("A4") = "Reporting Date"
    
        .Range("B4") = "Date"
    
        .Range("C4") = "Department"
    
        .Range("D4") = "Team"
    
        .Range("E4") = "Function"
    
        .Range("F4") = "Profile"
    
        .Range("G4") = "Level"
    
        .Range("H4") = "Heads"
    
        .Range("I4") = "FTE"
    
        .Range("J4") = "Effect FTE"
    
    End With
    
    Columns("A:B").NumberFormat = "dd/mm/yyyy"
    
    With ws1.Range("A4:J4").Borders(xlTop)
    
        .LineStyle = xlContinuous
    
        .Weight = xlThin
    
    End With
    
    With ws1.Range("A4:J4").Borders(xlBottom)
    
        .LineStyle = xlContinuous
    
        .Weight = xlThin
    
    End With
    
    ws1.Range("A4:J4").Font.Bold = True
    
    ws1.Range("A4:J4").ColumnWidth = 15
    
    fName = Dir(ThisWorkbook.Path & "\*.xl*")
    
    Do Until fName = ""
    
        If Not fName = ThisWorkbook.Name Then Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\" & fName) Else Set wb2 = ThisWorkbook
     
            Set ws2 = wb2.Sheets("XYZ")
            ws2.Name = "Data"
    
            For i = 8 To ws2.UsedRange.Columns.Count Step 3
    
                For j = 4 To 35
    
                    If Not ws2.Cells(j, i) = "" Then
    
                        lRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    
                        ws1.Range("A" & lRow) = Date
    
                        ws1.Range("B" & lRow) = ws2.Cells(1, i)
    
                        ws1.Range("C" & lRow) = ws2.Range("B2")
    
                        ws1.Range("D" & lRow) = ws2.Name
    
                        If ws2.Range("C" & j) = "" Then
    
                            ws1.Range("E" & lRow) = ws2.Range("C" & j).End(xlUp)
    
                        Else
    
                            ws1.Range("E" & lRow) = ws2.Range("C" & j)
    
                        End If
    
                        ws1.Range("F" & lRow) = ws2.Range("D" & j)
    
                        ws1.Range("G" & lRow) = ws2.Range("E" & j)
    
                        ws1.Range("H" & lRow) = ws2.Cells(j, i)
    
                        ws1.Range("I" & lRow) = ws2.Cells(j, i + 1)
    
                        ws1.Range("J" & lRow) = ws2.Cells(j, i + 2)
    
                    End If
    
                Next j
    
            Next i
    
            
    
        fName = Dir()
    
    Loop
    
    ws1.Range("A5:J" & ws1.Range("A" & Rows.Count).End(xlUp).Row).Sort key1:=Range("B4")
    
    MsgBox ("Importierung erfolgreich!")
    
    End Sub
    Attached Files Attached Files
    Last edited by vio.coman; 2014-04-25 at 06:36.

  2. Subscribe to our Windows Secrets Newsletter - It's Free!

    Get our unique weekly Newsletter with tips and techniques, how to's and critical updates on Windows 7, Windows 8, Windows XP, Firefox, Internet Explorer, Google, etc. Join our 480,000 subscribers!

    Excel 2013: The Missing Manual

    + Get this BONUS — free!

    Get the most of Excel! Learn about new features, basics of creating a new spreadsheet and using the infamous Ribbon in the first chapter of Excel 2013: The Missing Manual - Subscribe and download Chapter 1 for free!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •