vba remove blank cells from different columns

[dappy]

Hi folks,

I have this situation, where i need to copy the whole sheet to a blank sheet but only the cells with information. i have the below code but i cant get it to work correctly. i've tried to do it per column but that doesnt work either.

any help greatly appreciated.

test_rc1.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X
1	start	first	sec	thr	oper	start first	haps	oper	start	sec	third			start	first	sec	thr	oper	start first	haps	oper	start	sec	third
2	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
3	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
4	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
5	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
6	xx	xx	xx	xx				xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
7	xx	xx	xx	xx				xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
8	xx	xx	xx	xx				xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
9								xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
10								xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
11								xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
12	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
13	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
14	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
15	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx			xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
16	xx	xx	xx	xx				xx	xx	xx	xx			xx	xx	xx	xx				xx	xx	xx	xx
17	xx	xx	xx	xx				xx	xx	xx	xx			xx	xx	xx	xx				xx	xx	xx	xx
18	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx			xx	xx	xx	xx				xx	xx	xx	xx
19								xx	xx	xx	xx			xx	xx	xx	xx				xx	xx	xx	xx
20								xx	xx	xx	xx			xx	xx	xx	xx				xx	xx	xx	xx
21					xx	xx	xx	xx	xx	xx	xx			xx	xx	xx	xx				xx	xx	xx	xx
22					xx	xx	xx							xx	xx	xx	xx				xx	xx	xx	xx
23					xx	xx	xx														xx	xx	xx	xx
24	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
25	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx	xx
26	xx	xx	xx	xx
27	xx	xx	xx	xx
28	xx	xx	xx	xx
29	xx	xx	xx	xx
30	xx	xx	xx	xx
Sheet1

Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
  
   Ary = Intersect(Sheets("sheet1").UsedRange, Sheets("sheet1").Range("A:K"))
   ReDim Nary(1 To UBound(Ary), 1 To 16)
   For r = 1 To UBound(Ary)
      If Ary(r, 1) <> "" Then
         nr = nr + 1
         For c = 1 To UBound(Ary, 2)
            Nary(nr, c) = Ary(r, c)
         Next c
      End If
   Next r
   Sheets("sheet2").Range("A1").Resize(nr, 16).Value = Nary
   '  End Sub
'Private Sub CopyItOver()
  Set NewBook = Workbooks.Add
  Workbooks("test_rc1.xlsm").Worksheets("sheet2").Range("A1:P1000").Copy
  NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues)

 

[dappy]

Cancel that folks, figured it out. thanks anyway

 

[smozgur]

Cancel that folks, figured it out. thanks anyway

Glad to hear you figured it out.

Do you mind posting about your solution? Then it is perfectly fine to mark your post as the solution to help future readers.

Thanks.

 

[dappy]

so, somewhat untidy i know but this works for me. for each set of columns have a set of declared variables. below is a selection of three sets, should be self explanatory. with my data the sets of columns have the same count, i think that's where i was going wrong.

Sub delete_blank_2()

Dim Ary As Variant, Nary As Variant
Dim r As Long, c As Long, nr As Long
Dim AryQ As Variant, NaryQ As Variant
Dim rQ As Long, cQ As Long, nrQ As Long
Dim Aryw As Variant, Naryw As Variant
Dim rw As Long, cw As Long, nrw As Long

Sheets("sheet2").Cells.Clear

Ary = Intersect(Sheets("sheet1").UsedRange, Sheets("sheet1").Range("b:c"))
ReDim Nary(1 To UBound(Ary), 1 To 16)
For r = 1 To UBound(Ary)
If Ary(r, 1) <> "" Then
nr = nr + 1
For c = 1 To UBound(Ary, 2)
Nary(nr, c) = Ary(r, c)
Next c
End If
Next r
Sheets("sheet2").Range("b1").Resize(nr, 16).Value = Nary




AryQ = Intersect(Sheets("sheet1").UsedRange, Sheets("sheet1").Range("e:g"))
ReDim NaryQ(1 To UBound(AryQ), 1 To 16)
For rQ = 1 To UBound(AryQ)
If AryQ(rQ, 1) <> "" Then
nrQ = nrQ + 1
For cQ = 1 To UBound(AryQ, 2)
NaryQ(nrQ, cQ) = AryQ(rQ, cQ)
Next cQ
End If
Next rQ
Sheets("sheet2").Range("e1").Resize(nr, 16).Value = NaryQ



Aryw = Intersect(Sheets("sheet1").UsedRange, Sheets("sheet1").Range("i:j"))
ReDim Naryw(1 To UBound(Aryw), 1 To 16)
For rw = 1 To UBound(Aryw)
If Aryw(rw, 1) <> "" Then
nrw = nrw + 1
For cw = 1 To UBound(Aryw, 2)
Naryw(nrw, cw) = Aryw(rw, cw)
Next cw
End If
Next rw
Sheets("sheet2").Range("i1").Resize(nr, 16).Value = Naryw

End Sub

 

[smozgur]

Thanks for posting your solution!