How can I post sources file name next to source data pasted into compiled workbook

[karp1]

Hi everyone! I am relatively new to using macros and have been having some trouble using macros to compile data into a new excel sheet. My goal is to have a sheet that looks as follows:

Item Name	Measured Value	Source File Name
A	X	Patient1.xls
B	X	Patient1.xls
C	X	Patient1.xls
A	X	Patient2.xls
B	X	Patient2.xls
C	X	Patient2.xls
A	X	Patient3.xls

I have written a macro that takes the Item Name and the Measured Value and posts it into a compileddata sheet. The code I'm using is:

Sub DataTransposing()
strP = "F:\User\Macros\Datafolder"
                                           
strF = Dir(strP & "\*.xls")               
      
  
Do While strF <> vbNullString
    Workbooks.Open Filename:= _
        "F:\User\Macros\CompiledData.xlsx"
   
    Workbooks.Open (strP & "\" & strF)
    Sheets("Sheet1").Activate
    Range("A3:AZ3").Select                  'Change as required
    Selection.Copy
      
  Windows("CompiledData.xlsx").Activate
    'Change as required
    Sheets("Sheet1").Activate
    Range("B" & Rows.Count).End(xlUp).Offset(1).Select                  
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
  
    Workbooks.Open (strP & "\" & strF)
    Sheets("Sheet1").Activate
    Range("A1:AZ1").Select                  'Change as required
    Selection.Copy
  
    ActiveWorkbook.Save
        
    ActiveWorkbook.Close
        
    Windows("CompiledData.xlsx").Activate
    'Change as required
    Sheets("Sheet1").Activate
    Range("A" & Rows.Count).End(xlUp).Offset(1).Select                     'Change as required
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
          
    ActiveWorkbook.Sheets(1).Activate
  
    ActiveWorkbook.Save
        
    ActiveWorkbook.Close            'Closes the active workbook
  
  
    strF = Dir()
  
Loop
  
End Sub

I am looking to add some code which would paste the file name of the sheet from which the Item Name and Measured Value are taken in Column C, ideally filling every row. I hope the table above is helpful to visualize what I mean. Thank you!!

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub DataTransposing()
   Dim strP As String, strF As String
   Dim Wbk As Workbook
   Dim Ws As Worksheet
  
   strP = "F:\User\Macros\Datafolder"
   strF = Dir(strP & "\*.xls")
  
   If strF <> "" Then
      Set Wbk = Workbooks.Open("F:\User\Macros\CompiledData.xlsx")
      Set Ws = Wbk.Sheets("Sheet1")
   End If
  
   Do While strF <> vbNullString
      Workbooks.Open (strP & "\" & strF)
      Ws.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues, , , True
      Sheets("Sheet1").Range("A1:AZ1").Copy
      With Ws.Range("A" & Rows.Count).End(xlUp)
         .Offset(1).PasteSpecial xlPasteValues, , , True
         Sheets("Sheet1").Range("A3:AZ3").Copy
         .Offset(1, 1).PasteSpecial xlPasteValues, , , True
         .Offset(1, 2).Resize(52).Value = strF
      End With
      ActiveWorkbook.Close False
      strF = Dir()
   Loop
   Wbk.Close True
End Sub

 

[karp1]

Thank you SO much!! This is also a much more efficient code. I changed the inputs slightly to reflect the new format of the source data that I am using and had to adjust to put the copy step ahead of the paste step and ended up with the following code which works great:

Sub DataTransposing1()
   Dim strP As String, strF As String
   Dim Wbk As Workbook
   Dim Ws As Worksheet
 
   strP = "Z:\User2\Macro\DataFolder" 'Location of your data which has been put into the template
   strF = Dir(strP & "\*.xls")
 
   If strF <> "" Then
      Set Wbk = Workbooks.Open("Z:\User\Macro\CompiledData.xlsx")
      Set Ws = Wbk.Sheets("Sheet1")
   End If
 
   Do While strF <> vbNullString
      Workbooks.Open (strP & "\" & strF)
      Sheets("Sheet1").Range("L1:CZ1").Copy
      Ws.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues, , , True
     
      With Ws.Range("B" & Rows.Count).End(xlUp)
         .Offset(1).PasteSpecial xlPasteValues, , , True
         Sheets("Sheet1").Range("L3:CZ3").Copy
         .Offset(1, 1).PasteSpecial xlPasteValues, , , True
         .Offset(1, 2).Resize(94).Value = strF
      End With
      ActiveWorkbook.Close False
      strF = Dir()
   Loop
   Wbk.Close True
End Sub

If I may ask for some more of your time, this code does have a small quirk. It basically results in a doubling of the A column, so that the identical data being copied from L1:LZ1 in the source sheet is being pasted into both columns A and B. The L3:CZ1 column is then located in the C column of the compiled sheet. However, this is a trivial issue because I can just delete one of the columns in the final sheet.
Could you also maybe tell me which line of this code is leading to the filename being included in the compiled worksheet? I think this would help me learn more about how to use macros!

You have helped me so much and saved me a lot of time!!! Thanks for your help.

 

[Fluff]

The code should be

Sub DataTransposing()
   Dim strP As String, strF As String
   Dim Wbk As Workbook
   Dim Ws As Worksheet
   
   strP = "F:\User\Macros\Datafolder"
   strF = Dir(strP & "\*.xls")
   
   If strF <> "" Then
      Set Wbk = Workbooks.Open("F:\User\Macros\CompiledData.xlsx")
      Set Ws = Wbk.Sheets("Sheet1")
   End If
   
   Do While strF <> vbNullString
      Workbooks.Open (strP & "\" & strF)
      Sheets("Sheet1").Range("L1:CZ1").Copy
      With Ws.Range("A" & Rows.Count).End(xlUp)
         .Offset(1).PasteSpecial xlPasteValues, , , True
         Sheets("Sheet1").Range("L3:CZ3").Copy
         .Offset(1, 1).PasteSpecial xlPasteValues, , , True
         .Offset(1, 2).Resize(94).Value = strF
      End With
      ActiveWorkbook.Close False
      strF = Dir()
   Loop
   Wbk.Close True
End Sub

I originally left a line of code in, that should have been removed.
It's this line that adds the filename .Offset(1, 2).Resize(94).Value = strF