Data Extraction multiple Sheets & Multiple Cells

5

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
 
Sort by date Sort by votes
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
 
Upvote 0

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
That works perfectly,

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

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

could I then just change the range A8:U17 to encompass these as well?[/TD]
[/TR]
</tbody>[/TABLE]

and could I change it so that the it populates cells A1:O1 instead of A1:A15?
 
Upvote 0
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?
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

Z
  • Question Question
VBA code to create a new workbook from multiple sheets of current workbook
Replies
9
Views
4K
Micron
M
J
  • Question Question
Macro for copying data from multiple sheets to a common sheet based on a cell value
Replies
0
Views
411
jmk15315
J
T
  • Solved
Combining Data from Multiple Sheets
2
Replies
16
Views
1K
alansidman
A
J
  • Solved
Macro to Delete Blank Rows in Multiple Sheets, Not Whole Workbook
Replies
5
Views
2K
rollis13
rollis13
willow1985
  • Solved
Assistance with VBA error handling - a cell not matching data set
2
Replies
10
Views
1K
willow1985
willow1985

Forum statistics

Threads
1,223,236
Messages
6,170,912
Members
452,366
Latest member
TePunaBloke

Share this page

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
Back
Top