VBA Code to Remove columns and rows

Navi_G

Navi_G

Board Regular
Joined
May 30, 2018
Messages
94
Office Version
  1. 2016
Platform
  1. Windows
Hi All Expertise,
i have to make a report multiple times a day and it takes too much time because it has different steps pls provide a VBA code to do it automatically by single key or button. Step wise description:
Step 1. I go to first data sheet select from (C17:AN17) to last data row then copy it and paste in a new worksheet.
Step 2. I select 2nd data sheet from (C21:AN21) to last data row which will be between 1 to 1000, copy it and paste in that sheet where i paste 1st sheet data. (Below that data).
Step 3. Delete Row# 2 & 3.
Step 4. Delete Columns (TOTAL PCS, SHRINKAG, Width, Shade, Balance & all blanks columns).
Step 5. Copy data from (D1:Last data cell) and paste in Row # 2.
Step 6. Delete Row # 01.
Step 7. Insert Filter. Open filter in column C and delete blank rows.
Step 8. Delete column C.
Now I have only that data which I require.
Step 9. Unpivot Columns. (I have VBA code for it)
Code: 
Sub Rearrange_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, uba2 As Long
  
  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, Cells(1, Columns.Count).End(xlToLeft).Column).Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * (uba2 - 2), 1 To 4)
  For i = 2 To UBound(a)
    For j = 3 To uba2
      If Len(a(i, j)) > 0 Then
        k = k + 1
        b(k, 1) = a(i, 1)
        b(k, 2) = a(i, 2)
        b(k, 3) = a(1, j)
        b(k, 4) = a(i, j)
      End If
    Next j
  Next i
  Range("A" & Rows.Count).End(xlUp).Offset(3).Resize(, 4).Value = Array("QTY", "CUT #", "Size", "Bundle")
  Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 4).Value = b
End Sub
Step 10. Some cuts have more than on value row assign them numbering. (I have VBA for this
Code: 
Sub Bundles()
       
       Dim vWS As Worksheet
       Dim vA, vA2()
       Dim vR As Long, vSum As Long, vC As Long
       Dim vN As Long, vN2 As Long, vN3 As Long
       
       Set vWS = ActiveSheet
       With vWS
              vR = .Cells(Rows.Count, 4).End(xlUp).Row
              vSum = Application.Sum(.Range("D2:D" & vR))
              ReDim Preserve vA2(1 To vSum, 1 To 4)
              vA = .Range("A2:D" & vR)
              For vN = 1 To vR - 1
                     For vN2 = 1 To vA(vN, 4)
                            vC = vC + 1
                            For vN3 = 1 To 4
                                   vA2(vC, vN3) = vA(vN, vN3)
                            Next vN3
                     Next vN2
              Next vN
       End With
       vC = 1
       For vN = 1 To vSum - 2
              vA2(vN, 4) = vC
              If vA2(vN + 1, 2) = vA2(vN, 2) Then
                     vC = vC + 1
                     vA2(vN + 1, 4) = vC
              Else
                     vA2(vN + 1, 4) = 1
                     vC = 1
              End If
       Next vN
       Application.ScreenUpdating = False
       Sheets.Add
       With ActiveSheet
                     vWS.Range("A1:D1").Copy .Range("A1:D1")
                     .Cells(2, 1).Resize(vSum, 4) = vA2
       End With
       Application.ScreenUpdating = True
       
End Sub
Kindly give VBA coding to remove unnecessary rows and columns and also compile all coding in one.
Data Sheets may be 1 to 15.
Link of my data file is
GU 15436 15437 15542 15543.xlsx

i have already post this question in Excel Forum but enable to get any answer.
Remove Un-Necessary Data by VBA
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
Are you have only Data Sheets In your workbook?
 
Upvote 0
Without Deleting other sheets, For Step 1 to 8 Try this code:
VBA Code: 
Sub RefineData()
Dim i As Long, j As Long, Lr As Long, LrD As Long, N As Long, vWS As Worksheet, vR As Long
Dim a As Variant, b As Variant, k As Long, uba2 As Long, vSum As Long, vC As Long
Dim vN As Long, vN2 As Long, vN3 As Long, vA, vA2()
 Application.ScreenUpdating = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Result"
For i = 1 To ThisWorkbook.Sheets.Count - 1
If Sheets(i).Range("C20").Value = "TOTAL PCS" Then
Lr = Sheets(i).Range("D21").End(xlDown).Row
If Lr = Rows.Count Then GoTo Step2
LrD = Sheets("Result").Range("B" & Rows.Count).End(xlUp).Row + 1
If LrD = 2 Then
Sheets(i).Range("C17:AN" & Lr).Copy
Sheets("Result").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
Sheets(i).Range("C21:AN" & Lr).Copy
Sheets("Result").Range("A" & LrD).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Step2:
End If
Next i
If Sheets("Result").Range("H4").Value = "" Then
Sheets("Result").Range("H4").Value = Sheets("Result").Range("G4").Value
Sheets("Result").Range("G4").Value = ""
End If
Sheets("Result").Rows("2:3").Delete
For i = 11 To 1 Step -1
  Select Case Trim(Sheets("Result").Cells(2, i).Value)
   Case "TOTAL PCS", "SHRINKAG", "Width", "Shade", "Balance", ""
    Sheets("Result").Columns(i).Delete
   End Select
Next i
Sheets("Result").Range("D2:N2").Value = Sheets("Result").Range("D1:N1").Value
Sheets("Result").Rows("1").Delete
For i = Sheets("Result").Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
N = Sheets("Result").Range("C" & Sheets("Result").Range("C" & Rows.Count).End(xlUp).Row).End(xlUp).Row - 1
If N < 2 Then GoTo Step10
Sheets("Result").Rows(N).Delete
Next i
Step10:
Sheets("Result").Columns(3).Delete
Application.ScreenUpdating = True
End Sub
Then Run Other Codes.
 
Upvote 0
Or try this code for All Step1 to 10:
VBA Code: 
Sub RefineData2()
Dim i As Long, j As Long, Lr As Long, LrD As Long, N As Long, vWS As Worksheet, vR As Long
Dim a As Variant, b As Variant, k As Long, uba2 As Long, vSum As Long, vC As Long
Dim vN As Long, vN2 As Long, vN3 As Long, vA, vA2()
 Application.ScreenUpdating = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Result"
For i = 1 To ThisWorkbook.Sheets.Count - 1
If Sheets(i).Range("C20").Value = "TOTAL PCS" Then
Lr = Sheets(i).Range("D21").End(xlDown).Row
If Lr = Rows.Count Then GoTo Step2
LrD = Sheets("Result").Range("B" & Rows.Count).End(xlUp).Row + 1
If LrD = 2 Then
Sheets(i).Range("C17:AN" & Lr).Copy
Sheets("Result").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
Sheets(i).Range("C21:AN" & Lr).Copy
Sheets("Result").Range("A" & LrD).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Step2:
End If
Next i
If Sheets("Result").Range("H4").Value = "" Then
Sheets("Result").Range("H4").Value = Sheets("Result").Range("G4").Value
Sheets("Result").Range("G4").Value = ""
End If
Sheets("Result").Rows("2:3").Delete
For i = 11 To 1 Step -1
  Select Case Trim(Sheets("Result").Cells(2, i).Value)
   Case "TOTAL PCS", "SHRINKAG", "Width", "Shade", "Balance", ""
    Sheets("Result").Columns(i).Delete
   End Select
Next i
Sheets("Result").Range("D2:N2").Value = Sheets("Result").Range("D1:N1").Value
Sheets("Result").Rows("1").Delete
For i = Sheets("Result").Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
N = Sheets("Result").Range("C" & Sheets("Result").Range("C" & Rows.Count).End(xlUp).Row).End(xlUp).Row - 1
If N < 2 Then GoTo Step10
Sheets("Result").Rows(N).Delete
Next i
Step10:
Sheets("Result").Columns(3).Delete
With Sheets("Result")
  a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * (uba2 - 2), 1 To 4)
  For i = 2 To UBound(a)
    For j = 3 To uba2
      If Len(a(i, j)) > 0 Then
        k = k + 1
        b(k, 1) = a(i, 1)
        b(k, 2) = a(i, 2)
        b(k, 3) = a(1, j)
        b(k, 4) = a(i, j)
      End If
    Next j
  Next i
  Lr = .Range("A" & Rows.Count).End(xlUp).Row
  LrD = .Cells(1, Columns.Count).End(xlToLeft).Column
  Range(.Cells(1, 1), .Cells(Lr, LrD)).ClearContents
  .Range("A" & Rows.Count).End(xlUp).Resize(, 4).Value = Array("QTY", "CUT #", "Size", "Bundle")
  .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 4).Value = b
    
    vR = .Cells(Rows.Count, 4).End(xlUp).Row
    vSum = Application.Sum(.Range("D2:D" & vR))
     ReDim Preserve vA2(1 To vSum, 1 To 4)
    vA = .Range("A2:D" & vR)
      For vN = 1 To vR - 1
        For vN2 = 1 To vA(vN, 4)
          vC = vC + 1
           For vN3 = 1 To 4
             vA2(vC, vN3) = vA(vN, vN3)
           Next vN3
        Next vN2
      Next vN
 End With
       
  vC = 1
   For vN = 1 To vSum - 2
    vA2(vN, 4) = vC
     If vA2(vN + 1, 2) = vA2(vN, 2) Then
      vC = vC + 1
      vA2(vN + 1, 4) = vC
     Else
      vA2(vN + 1, 4) = 1
      vC = 1
     End If
   Next vN
 Sheets.Add(After:=Sheets(Sheets.Count)).Name = "FinalResult"
   With ActiveSheet
        Sheets("Result").Range("A1:D1").Copy .Range("A1:D1")
       .Cells(2, 1).Resize(vSum, 4) = vA2
  End With
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
Dear Expert,
Thanks a lot for this help its amazing.
 
Upvote 0
Dear Expert,
Sorry for disturbing again your given code is awesome but is not working in following type sheet can you pls check.

GU 15368.xlsx
 
Upvote 0
Try this For Both Files:
VBA Code: 
Sub RefineData3()
Dim i As Long, j As Long, Lr As Long, LrD As Long, N As Long, vWS As Worksheet, vR As Long
Dim a As Variant, b As Variant, k As Long, uba2 As Long, vSum As Long, vC As Long
Dim vN As Long, vN2 As Long, vN3 As Long, vA, vA2()
 Application.ScreenUpdating = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Result"
For i = 1 To ThisWorkbook.Sheets.Count - 1
If Sheets(i).Range("C20").Value = "TOTAL PCS" Then
Lr = Sheets(i).Range("D21").End(xlDown).Row
If Lr = Rows.Count Then GoTo Step2
Debug.Print Sheets(i).Name
LrD = Sheets("Result").Range("B" & Rows.Count).End(xlUp).Row + 1
If LrD = 2 Then
Sheets(i).Range("C17:AN" & Lr).Copy
Sheets("Result").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
Sheets(i).Range("C21:AN" & Lr).Copy
Sheets("Result").Range("A" & LrD).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Step2:
End If
Next i
If Sheets("Result").Range("H4").Value = "" Then
Sheets("Result").Range("H4").Value = Sheets("Result").Range("G4").Value
Sheets("Result").Range("G4").Value = ""
End If
Sheets("Result").Rows("2:3").Delete
For i = 11 To 1 Step -1
  Select Case Trim(Sheets("Result").Cells(2, i).Value)
   Case "TOTAL PCS", "SHRINKAG", "Width", "Shade", "Balance", ""
    Sheets("Result").Columns(i).Delete
   End Select
Next i
With Sheets("Result")
.Range("D2:AN2").Value = .Range("D1:AN1").Value
.Rows("1").Delete
LrD = .Range("B" & Rows.Count).End(xlUp).Row
  .Range("A1:AN" & LrD).AutoFilter Field:=3, Criteria1:="<>"
  .Range("A1:AN" & LrD).SpecialCells(xlCellTypeVisible).Copy
  .Range("A" & LrD + 1).Select
   ActiveSheet.Paste
  .Range("A1:AN" & LrD).AutoFilter
  .Rows("1:" & LrD).Delete
  .Columns(3).Delete
  
  a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * (uba2 - 2), 1 To 4)
  For i = 2 To UBound(a)
    For j = 3 To uba2
      If Len(a(i, j)) > 0 Then
        k = k + 1
        b(k, 1) = a(i, 1)
        b(k, 2) = a(i, 2)
        b(k, 3) = a(1, j)
        b(k, 4) = a(i, j)
      End If
    Next j
  Next i
  Lr = .Range("A" & Rows.Count).End(xlUp).Row
  LrD = .Cells(1, Columns.Count).End(xlToLeft).Column
  Range(.Cells(1, 1), .Cells(Lr, LrD)).ClearContents
  .Range("A" & Rows.Count).End(xlUp).Resize(, 4).Value = Array("QTY", "CUT #", "Size", "Bundle")
  .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 4).Value = b
    
    vR = .Cells(Rows.Count, 4).End(xlUp).Row
    vSum = Application.Sum(.Range("D2:D" & vR))
     ReDim Preserve vA2(1 To vSum, 1 To 4)
    vA = .Range("A2:D" & vR)
      For vN = 1 To vR - 1
        For vN2 = 1 To vA(vN, 4)
          vC = vC + 1
           For vN3 = 1 To 4
             vA2(vC, vN3) = vA(vN, vN3)
           Next vN3
        Next vN2
      Next vN
 End With
       
  vC = 1
   For vN = 1 To vSum - 2
    vA2(vN, 4) = vC
     If vA2(vN + 1, 2) = vA2(vN, 2) Then
      vC = vC + 1
      vA2(vN + 1, 4) = vC
     Else
      vA2(vN + 1, 4) = 1
      vC = 1
     End If
   Next vN
 Sheets.Add(After:=Sheets(Sheets.Count)).Name = "FinalResult"
   With ActiveSheet
        Sheets("Result").Range("A1:D1").Copy .Range("A1:D1")
       .Cells(2, 1).Resize(vSum, 4) = vA2
  End With
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thanks a lot its working properly thanks again.
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question
VBA change cell colour
2
Replies
17
Views
699
kevin9999
K
D
  • Question
VBA Code to split week ranges into separate lines (additional code required)
Replies
0
Views
450
DotExcel
D
Navi_G
  • Question
Want to Run this code as a Personal Marco
Replies
0
Views
370
Navi_G
Navi_G
Navi_G
  • Question
How to apply my VBA Code on multiple workbooks in a folder
2 3
Replies
24
Views
2K
Navi_G
Navi_G
Navi_G
  • Question
Run Time Error-13
Replies
9
Views
502
Marc L
Marc L

Forum statistics

Threads
1,214,833
Messages
6,121,862
Members
449,052
Latest member
Fuddy_Duddy

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