Data Extraction multiple Sheets & Multiple Cells

5h1v

Board Regular
Joined
Oct 11, 2012
Messages
69
Hey,

I have tried to make a macro that I can select a folder and then export all the data from multiple sheets that are identical in layout to one sheet I have come up with this but I cant seem to get it to work, it is always sheet 4 and that's were I seem to be falling down, any ideas?
Code:
Sub FolderPicker_ExportData()

Dim wb1 As Workbook, wb2 As Workbook
Set wb1 = ThisWorkbook
Dim sPath As String: Dim sFile As String
Dim L As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select one folder"
.AllowMultiSelect = False
If .Show = True Then
sPath = .SelectedItems(1) & "\"
sFile = Dir(sPath & "*.xls*")
If sFile <> "" Then


Application.ScreenUpdating = False
L = 1
Set ws = wb1.Sheets.Add(before:=wb1.Sheets(1))
Do Until sFile = ""
Set wb2 = Workbooks.Open(sPath & sFile)
ws.Cells(L, "A").Value = wb2.Sheets(4).Range("G3,a6,A8,c8,d8,g8,m8,n8,08,p8,q8,r8,s8,t8,u8").Value
ws.Cells(L, "B").Value = wb2.Sheets(4).Range("G3,a6,A9,c9,d9,g9,m9,n9,09,p9,q9,r9,s9,t9,u9").Value
ws.Cells(L, "C").Value = wb2.Sheets(4).Range("G3,a6,A10,c10,d10,g10,m10,n10,010,p10,q10,r10,s10,t10,u10").Value
ws.Cells(L, "D").Value = wb2.Sheets(4).Range("G3,a6,A11,c11,d11,g11,m11,n11,011,p11,q11,r11,s11,t11,u11").Value
ws.Cells(L, "E").Value = wb2.Sheets(4).Range("G3,a6,A12,c12,d12,g12,m12,n12,012,p12,q12,r12,s12,t12,u12").Value
ws.Cells(L, "F").Value = wb2.Sheets(4).Range("G3,a6,A13,c13,d13,g13,m13,n13,013,p13,q13,r13,s13,t13,u13").Value
ws.Cells(L, "G").Value = wb2.Sheets(4).Range("G3,a6,A14,c14,d14,g14,m14,n14,014,p14,q14,r14,s14,t14,u14").Value
ws.Cells(L, "H").Value = wb2.Sheets(4).Range("G3,a6,A15,c15,d15,g15,m15,n15,015,p15,q15,r15,s15,t15,u15").Value
ws.Cells(L, "I").Value = wb2.Sheets(4).Range("G3,a6,A16,c16,d16,g16,m16,n16,016,p16,q16,r16,s16,t16,u16").Value
ws.Cells(L, "J").Value = wb2.Sheets(4).Range("G3,a6,A17,c17,d17,g17,m17,n17,017,p17,q17,r17,s17,t17,u17").Value
L = L + 1


wb2.Close False
sFile = Dir()
Loop


Application.ScreenUpdating = True


Else
MsgBox "no files found"
End If
Else
MsgBox "Cancel"
End If
End With
ActiveWorkbook.Save
End Sub

Any help would be appreciated
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,860
Office Version
  1. 365
Platform
  1. Windows
Ok, how about
Code:
Sub FolderPicker_ExportData()
   Dim wb1 As Workbook, wb2 As Workbook
   Dim Ws As Worksheet
   Dim Ary As Variant
   Dim sPath As String, sFile As String
   Dim L As Long
   
   Set wb1 = ThisWorkbook
   Set Ws = wb1.Sheets.Add(before:=wb1.Sheets(1))

   With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "Please select one folder"
      .AllowMultiSelect = False
      If .Show = True Then sPath = .SelectedItems(1) & "\"
   End With
   sFile = Dir(sPath & "*.xls*")
   If sFile = "" Then
      MsgBox "No files found"
      Exit Sub
   End If
   
   Application.ScreenUpdating = False
   L = 1
   Do Until sFile = ""
      Set wb2 = Workbooks.Open(sPath & sFile)
      Ary = Application.Index(wb2.Sheets(4).Range("A8:U17").Value, Evaluate("row(1:10)"), Array(1, 3, 4, 7, 13, 14, 15, 16, 17, 18, 19, 20, 21))
      Ws.Range("A" & L).Resize(, 10).Value = wb2.Sheets(4).Range("G3").Value
      Ws.Range("A" & L + 1).Resize(, 10).Value = wb2.Sheets(4).Range("A6").Value
      Ws.Range("A" & L + 2).Resize(13, 10).Value = Application.Transpose(Ary)
      L = L + 15
      
      wb2.Close False
      sFile = Dir()
   Loop
   ActiveWorkbook.Save
End Sub
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.

5h1v

Board Regular
Joined
Oct 11, 2012
Messages
69
That works perfectly,

2 questions I have larger ranges I want this to apply to which are below;

G3,a6,A8,c8,d8,g8,m8,n8,08,p8,q8,r8,s8,t8,u8
G3,a6,A9,c9,d9,g9,m9,n9,09,p9,q9,r9,s9,t9,u9
G3,a6,A10,c10,d10,g10,m10,n10,010,p10,q10,r10,s10,t10,u10
G3,a6,A11,c11,d11,g11,m11,n11,011,p11,q11,r11,s11,t11,u11
G3,a6,A12,c12,d12,g12,m12,n12,012,p12,q12,r12,s12,t12,u12
G3,a6,A13,c13,d13,g13,m13,n13,013,p13,q13,r13,s13,t13,u13
G3,a6,A14,c14,d14,g14,m14,n14,014,p14,q14,r14,s14,t14,u14
G3,a6,A15,c15,d15,g15,m15,n15,015,p15,q15,r15,s15,t15,u15
G3,a6,A16,c16,d16,g16,m16,n16,016,p16,q16,r16,s16,t16,u16
G3,a6,A17,c17,d17,g17,m17,n17,017,p17,q17,r17,s17,t17,u17
G3,a18,A20,c20,d20,g20,m20,n20,020,p20,q20,r20,s20,t20,u20
G3,a18,A21,c21,d21,g21,m21,n21,021,p21,q21,r21,s21,t21,u21
G3,a18,A22,c22,d22,g22,m22,n22,022,p22,q22,r22,s22,t22,u22
G3,a18,A23,c23,d23,g23,m23,n23,023,p23,q23,r23,s23,t23,u23
G3,a18,A24,c24,d24,g24,m24,n24,024,p24,q24,r24,s24,t24,u24
G3,a18,A25,c25,d25,g25,m25,n25,025,p25,q25,r25,s25,t25,u25
G3,a18,A26,c26,d26,g26,m26,n26,026,p26,q26,r26,s26,t26,u26
G3,a18,A27,c27,d27,g27,m27,n27,027,p27,q27,r27,s27,t27,u27
G3,a18,A28,c28,d28,g28,m28,n28,028,p28,q28,r28,s28,t28,u28
G3,a18,A29,c29,d29,g29,m29,n29,029,p29,q29,r29,s29,t29,u29
G3,a30,a32,c32,d32,g32,m32,n32,o32,p32,q32,r32,s32,t32,u32
G3,a30,a33,c33,d33,g33,m33,n33,o33,p33,q33,r33,s33,t33,u33
G3,a30,a34,c34,d34,g34,m34,n34,o34,p34,q34,r34,s34,t34,u34
G3,a30,a35,c35,d35,g35,m35,n35,o35,p35,q35,r35,s35,t35,u35
G3,a30,a36,c36,d36,g36,m36,n36,o36,p36,q36,r36,s36,t36,u36
G3,a30,a37,c37,d37,g37,m37,n37,o37,p37,q37,r37,s37,t37,u37
G3,a30,a38,c38,d38,g38,m38,n38,o38,p38,q38,r38,s38,t38,u38
G3,a30,a39,c39,d39,g39,m39,n39,o39,p39,q39,r39,s39,t39,u39
G3,a30,a40,c40,d40,g40,m40,n40,o40,p40,q40,r40,s40,t40,u40
G3,a30,a41,c41,d41,g41,m41,n41,o41,p41,q41,r41,s41,t41,u41
G3,a30,a42,c42,d42,g42,m42,n42,o42,p42,q42,r42,s42,t42,u42
G3,a30,a43,c43,d43,g43,m43,n43,o43,p43,q43,r43,s43,t43,u43
G3,a30,a44,c44,d44,g44,m44,n44,o44,p44,q44,r44,s44,t44,u44
G3,a30,a45,c45,d45,g45,m45,n45,o45,p45,q45,r45,s45,t45,u45
G3,a30,a46,c46,d46,g46,m46,n46,o46,p46,q46,r46,s46,t46,u46
G3,a30,a47,c47,d47,g47,m47,n47,o47,p47,q47,r47,s47,t47,u47
G3,a30,a48,c48,d48,g48,m48,n48,o48,p48,q48,r48,s48,t48,u48
G3,a30,a49,c49,d49,g49,m49,n49,o49,p49,q49,r49,s49,t49,u49
G3,a30,a50,c50,d50,g50,m50,n50,o50,p50,q50,r50,s50,t50,u50
G3,a30,a51,c51,d51,g51,m51,n51,o51,p51,q51,r51,s51,t51,u51
G3,a30,a52,c52,d52,g52,m52,n52,o52,p52,q52,r52,s52,t52,u52
G3,a30,a53,c53,d53,g53,m53,n53,o53,p53,q53,r53,s53,t53,u53
G3,a30,a54,c54,d54,g54,m54,n54,o54,p54,q54,r54,s54,t54,u54
G3,a30,a55,c55,d55,g55,m55,n55,o55,p55,q55,r55,s55,t55,u55
G3,a30,a56,c56,d56,g56,m56,n56,o56,p56,q56,r56,s56,t56,u56
G3,a30,a57,c57,d57,g57,m57,n57,o57,p57,q57,r57,s57,t57,u57
G3,a30,a58,c58,d58,g58,m58,n58,o58,p58,q58,r58,s58,t58,u58
G3,a30,a59,c59,d59,g59,m59,n59,o59,p59,q59,r59,s59,t59,u59
G3,a30,a60,c60,d60,g60,m60,n60,o60,p60,q60,r60,s60,t60,u60
G3,a30,a61,c61,d61,g61,m61,n61,o61,p61,q61,r61,s61,t61,u61
G3,a30,a62,c62,d62,g62,m62,n62,o62,p62,q62,r62,s62,t62,u62
G3,a30,a63,c63,d63,g63,m63,n63,o63,p63,q63,r63,s63,t63,u63
G3,a64,a66,c66,d66,i66,m66,n66,o66,p66,q66,r66,s66,t66,u66
G3,a64,a67,c67,d67,i67,m67,n67,o67,p67,q67,r67,s67,t67,u67
G3,a64,a68,c68,d68,i68,m68,n68,o68,p68,q68,r68,s68,t68,u68
G3,a64,a69,c69,d69,i69,m69,n69,o69,p69,q69,r69,s69,t69,u69
G3,a64,a70,c70,d70,i70,m70,n70,o70,p70,q70,r70,s70,t70,u70
G3,a64,a71,c71,d71,i71,m71,n71,o71,p71,q71,r71,s71,t71,u71
G3,a64,a72,c72,d72,i72,m72,n72,o72,p72,q72,r72,s72,t72,u72
G3,a64,a73,c73,d73,i73,m73,n73,o73,p73,q73,r73,s73,t73,u73
G3,a64,a74,c74,d74,i74,m74,n74,o74,p74,q74,r74,s74,t74,u74
G3,a64,a75,c75,d75,i75,m75,n75,o75,p75,q75,r75,s75,t75,u75
G3,a64,a76,c76,d76,i76,m76,n76,o76,p76,q76,r76,s76,t76,u76
G3,a77,c80,d80,e80,f80,g80,h80,i80,j80
G3,a77,c81,d81,e81,f81,g81,h81,i81,j81
G3,a77,c82,d82,e82,f82,g82,h82,i82,j82
G3,a77,c83,d83,e83,f83,g83,h83,i83,j83
G3,a77,c84,d84,e84,f84,g84,h84,i84,j84
G3,a77,c85,d85,e85,f85,g85,h85,i85,j85
G3,a77,c86,d86,e86,f86,g86,h86,i86,j86
G3,a77,c87,d87,e87,f87,g87,h87,i87,j87
G3,a77,c80,d80,e80,f80,l80,m80,n80,o80
G3,a77,c81,d81,e81,f81,l81,m81,n81,o81
G3,a77,c82,d82,e82,f82,l82,m82,n82,o82
G3,a77,c83,d83,e83,f83,l83,m83,n83,o83
G3,a77,c84,d84,e84,f84,l84,m84,n84,o84
G3,a77,c85,d85,e85,f85,l85,m85,n85,o85
G3,a77,c86,d86,e86,f86,l86,m86,n86,o86
G3,a77,c87,d87,e87,f87,l87,m87,n87,o87
G3,a77,c80,d80,e80,f80,q80,r80,s80,t80
G3,a77,c81,d81,e81,f81,q81,r81,s81,t81
G3,a77,c82,d82,e82,f82,q82,r82,s82,t82
G3,a77,c83,d83,e83,f83,q83,r83,s83,t83
G3,a77,c84,d84,e84,f84,q84,r84,s84,t84
G3,a77,c85,d85,e85,f85,q85,r85,s85,t85
G3,a77,c86,d86,e86,f86,q86,r86,s86,t86
G3,a77,c87,d87,e87,f87,q87,r87,s87,t87
G3,a77,c90,d90,e90,f90,g90,h90,i90,j90
G3,a77,c91,d91,e91,f91,g91,h91,i91,j91
G3,a77,c92,d92,e92,f92,g92,h92,i92,j92
G3,a77,c93,d93,e93,f93,g93,h93,i93,j93
G3,a77,c94,d94,e94,f94,g94,h94,i94,j94
G3,a77,c95,d95,e95,f95,g95,h95,i95,j95
G3,a77,c96,d96,e96,f96,g96,h96,i96,j96
G3,a77,c97,d97,e97,f97,g97,h97,i97,j97
G3,a77,c90,d90,e90,f90,l90,m90,n90,o90
G3,a77,c91,d91,e91,f91,l91,m91,n91,o91
G3,a77,c92,d92,e92,f92,l92,m92,n92,o92
G3,a77,c93,d93,e93,f93,l93,m93,n93,o93
G3,a77,c94,d94,e94,f94,l94,m94,n94,o94
G3,a77,c95,d95,e95,f95,l95,m95,n95,o95
G3,a77,c96,d96,e96,f96,l96,m96,n96,o96
G3,a77,c97,d97,e97,f97,l97,m97,n97,o97
G3,a77,c90,d90,e90,f90,q90,r90,s90,t90
G3,a77,c91,d91,e91,f91,q91,r91,s91,t91
G3,a77,c92,d92,e92,f92,q92,r92,s92,t92
G3,a77,c93,d93,e93,f93,q93,r93,s93,t93
G3,a77,c94,d94,e94,f94,q94,r94,s94,t94
G3,a77,c95,d95,e95,f95,q95,r95,s95,t95
G3,a77,c96,d96,e96,f96,q96,r96,s96,t96
G3,a77,c97,d97,e97,f97,q97,r97,s97,t97

could I then just change the range A8:U17 to encompass these as well?

<colgroup><col width="64" style="width:48pt"> </colgroup><tbody>
</tbody>

and could I change it so that the it populates cells A1:O1 instead of A1:A15?
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,860
Office Version
  1. 365
Platform
  1. Windows
You would need to replicate the code for each block of cells, as it only works with contiguous rows.
For the 2nd question, I don't understand. If this G3,a6,A8,c8,d8,g8,m8,n8,08,p8,q8,r8,s8,t8,u8 goes in A1:O1 instead of A1:A15 where does this go G3,a6,A9,c9,d9,g9,m9,n9,09,p9,q9,r9,s9,t9,u9, as it can't go in B1:B15 anymore?
 

5h1v

Board Regular
Joined
Oct 11, 2012
Messages
69
Thats great I can replicate it for each block, they would drop into rows instead of columns so A1:01, A2:O2, A3:03 etc etc

Ill try replicating the rest now
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,860
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

If you don't want to transpose the date try
Code:
      Set wb2 = Workbooks.Open(sPath & sFile)
      Ary = Application.Index(wb2.Sheets(4).Range("A8:U17").Value, Evaluate("row(1:10)"), Array(1, 3, 4, 7, 13, 14, 15, 16, 17, 18, 19, 20, 21))
      Ws.Range("A" & L).Resize(10).Value = wb2.Sheets(4).Range("G3").Value
      Ws.Range("B" & L).Resize(10).Value = wb2.Sheets(4).Range("A6").Value
      Ws.Range("C" & L).Resize(10, 13).Value = Ary
      L = L + 10
 

5h1v

Board Regular
Joined
Oct 11, 2012
Messages
69
That works perfectly - thank you so much.

I have just tried to add in the next block and that is working perfectly as well.

You have no idea how much time you have saved me.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,860
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Glad to help & thanks for the feedback
 

5h1v

Board Regular
Joined
Oct 11, 2012
Messages
69
Sorry, I have one more questions, the blocks of data are different lengths so and it is not bringing back all the data, could you tell me why this is, I must have not changed everything that I needed to;

Code:
Sub FolderPicker_ExportData()
   Dim wb1 As Workbook, wb2 As Workbook
   Dim Ws As Worksheet
   Dim Ary As Variant
   Dim sPath As String, sFile As String
   Dim L As Long
   
   Set wb1 = ThisWorkbook
   Set Ws = wb1.Sheets.Add(before:=wb1.Sheets(1))


   With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "Please select one folder"
      .AllowMultiSelect = False
      If .Show = True Then sPath = .SelectedItems(1) & "\"
   End With
   sFile = Dir(sPath & "*.xls*")
   If sFile = "" Then
      MsgBox "No files found"
      Exit Sub
   End If
   
   Application.ScreenUpdating = False
   L = 1
   Do Until sFile = ""
      Set wb2 = Workbooks.Open(sPath & sFile)
      Ary = Application.Index(wb2.Sheets(4).Range("A8:U17").Value, Evaluate("row(1:10)"), Array(1, 3, 4, 7, 13, 14, 15, 16, 17, 18, 19, 20, 21))
      Ws.Range("A" & L).Resize(10).Value = wb2.Sheets(4).Range("G3").Value
      Ws.Range("B" & L).Resize(10).Value = wb2.Sheets(4).Range("A6").Value
      Ws.Range("C" & L).Resize(10, 13).Value = Ary
      L = L + 10
    Set wb2 = Workbooks.Open(sPath & sFile)
      Ary = Application.Index(wb2.Sheets(4).Range("A20:U29").Value, Evaluate("row(1:10)"), Array(1, 3, 4, 7, 13, 14, 15, 16, 17, 18, 19, 20, 21))
      Ws.Range("A" & L).Resize(10).Value = wb2.Sheets(4).Range("G3").Value
      Ws.Range("B" & L).Resize(10).Value = wb2.Sheets(4).Range("A18").Value
      Ws.Range("C" & L).Resize(10, 13).Value = Ary
      L = L + 10
    Set wb2 = Workbooks.Open(sPath & sFile)
      Ary = Application.Index(wb2.Sheets(4).Range("A32:U63").Value, Evaluate("row(1:31)"), Array(1, 3, 4, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15))
      Ws.Range("A" & L).Resize(10).Value = wb2.Sheets(4).Range("G3").Value
      Ws.Range("B" & L).Resize(10).Value = wb2.Sheets(4).Range("A30").Value
      Ws.Range("C" & L).Resize(10, 13).Value = Ary
      L = L + 31
    Set wb2 = Workbooks.Open(sPath & sFile)
      Ary = Application.Index(wb2.Sheets(4).Range("A66:U76").Value, Evaluate("row(1:11)"), Array(1, 3, 4, 7, 10, 11, 12, 13, 14, 15, 16, 17, 18))
      Ws.Range("A" & L).Resize(10).Value = wb2.Sheets(4).Range("G3").Value
      Ws.Range("B" & L).Resize(10).Value = wb2.Sheets(4).Range("A64").Value
      Ws.Range("C" & L).Resize(10, 13).Value = Ary
      L = L + 11
    Set wb2 = Workbooks.Open(sPath & sFile)
      Ary = Application.Index(wb2.Sheets(4).Range("A80:j87").Value, Evaluate("row(1:8)"), Array(1, 3, 4, 5, 6, 7, 8, 9, 10))
      Ws.Range("A" & L).Resize(10).Value = wb2.Sheets(4).Range("G3").Value
      Ws.Range("B" & L).Resize(10).Value = wb2.Sheets(4).Range("A77").Value
      Ws.Range("C" & L).Resize(10, 13).Value = Ary
         L = L + 8
    Set wb2 = Workbooks.Open(sPath & sFile)
      Ary = Application.Index(wb2.Sheets(4).Range("A80:o87").Value, Evaluate("row(1:8)"), Array(1, 3, 4, 5, 6, 12, 13, 14, 15))
      Ws.Range("A" & L).Resize(10).Value = wb2.Sheets(4).Range("G3").Value
      Ws.Range("B" & L).Resize(10).Value = wb2.Sheets(4).Range("A77").Value
      Ws.Range("C" & L).Resize(10, 13).Value = Ary
         L = L + 8
    Set wb2 = Workbooks.Open(sPath & sFile)
      Ary = Application.Index(wb2.Sheets(4).Range("A80:t87").Value, Evaluate("row(1:8)"), Array(1, 3, 4, 5, 6, 17, 18, 19, 20))
      Ws.Range("A" & L).Resize(10).Value = wb2.Sheets(4).Range("G3").Value
      Ws.Range("B" & L).Resize(10).Value = wb2.Sheets(4).Range("A77").Value
      Ws.Range("C" & L).Resize(10, 13).Value = Ary
         L = L + 8
      
      wb2.Close False
      sFile = Dir()
   Loop
   ActiveWorkbook.Save
End Sub
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,860
Office Version
  1. 365
Platform
  1. Windows
You need to change the resize like
Code:
      Set wb2 = Workbooks.Open(sPath & sFile)
      Ary = Application.Index(wb2.Sheets(4).Range("A8:U17").Value, Evaluate("row(1:10)"), Array(1, 3, 4, 7, 13, 14, 15, 16, 17, 18, 19, 20, 21))
      Ws.Range("A" & L).Resize(10).Value = wb2.Sheets(4).Range("G3").Value
      Ws.Range("B" & L).Resize(10).Value = wb2.Sheets(4).Range("A6").Value
      Ws.Range("C" & L).Resize(10, 13).Value = Ary
      L = L + 10
      Ary = Application.Index(wb2.Sheets(4).Range("A20:U29").Value, Evaluate("row(1:10)"), Array(1, 3, 4, 7, 13, 14, 15, 16, 17, 18, 19, 20, 21))
      Ws.Range("A" & L).Resize(10).Value = wb2.Sheets(4).Range("G3").Value
      Ws.Range("B" & L).Resize(10).Value = wb2.Sheets(4).Range("A18").Value
      Ws.Range("C" & L).Resize(10, 13).Value = Ary
      L = L + 10
      Ary = Application.Index(wb2.Sheets(4).Range("A32:U63").Value, Evaluate("row(1:31)"), Array(1, 3, 4, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15))
      Ws.Range("A" & L).Resize([COLOR=#ff0000]31[/COLOR]).Value = wb2.Sheets(4).Range("G3").Value
      Ws.Range("B" & L).Resize([COLOR=#ff0000]31[/COLOR]).Value = wb2.Sheets(4).Range("A30").Value
      Ws.Range("C" & L).Resize([COLOR=#ff0000]31[/COLOR], 13).Value = Ary
      L = L + 31
      Ary = Application.Index(wb2.Sheets(4).Range("A66:U76").Value, Evaluate("row(1:11)"), Array(1, 3, 4, 7, 10, 11, 12, 13, 14, 15, 16, 17, 18))
      Ws.Range("A" & L).Resize([COLOR=#ff0000]11[/COLOR]).Value = wb2.Sheets(4).Range("G3").Value
      Ws.Range("B" & L).Resize([COLOR=#ff0000]11[/COLOR]).Value = wb2.Sheets(4).Range("A64").Value
      Ws.Range("C" & L).Resize([COLOR=#ff0000]11[/COLOR], 13).Value = Ary
      L = L + 11
You also don't need all those workbook.open lines, just once at the start of the loop
 

Watch MrExcel Video

Forum statistics

Threads
1,130,142
Messages
5,640,367
Members
417,139
Latest member
bdmprasenjit

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top