Internet Codes from 1 Excel sheet to another

[Risque666]

Hi All
I have a complex spreadsheet I am trying to work on. But I am unsure where to start.
Please see the 2 sheets enclosed. The once called Internet Codes is all the Data I get from a program. I need to make a Macro that takes away all the crap from the sheet but leaves me the lines with only the internet codes.
Example: Below I have highlighted 2 codes out of the 400 codes the sheet has, I only want the codes and all the other crap removed.

Once the Macro has removed all the other rubbish - I should be left with just 400 cells with the 10 Digit codes on each cell.
Then if you look at the WIFI Code sheet - I want to know is there a way that I can make a macro that will allow me to import the codes into the cells on only 9 of the places at a time.
Example Below I have highlighted where the codes need to go on the 9 WiFi code inserts.

Is there away to do it so I put the macro and it inserts a new 9 codes after i print each one.

If you need more info let me know.. Im completely lost where to start on this.
let me know if there is a solution to make this work.. at least the first part at best to clear all rubbish but the codes.

 

[maabadi]

1. Are your Data is in Column A (All)?
2. what is sheet names (both)?
3. What is Cell Addresses ( 9 Cell) at Second sheet that Codes inserted there from first sheet?
4. what about print as PDF files?
5. if not what is printer name?

 

[maabadi]

This is example code if:
1. if all data at column A
2. First sheet name is Sheet1 & 2nd sheet name is Sheet2
3. Cell addresses at Sheet2 is B4, B10, B 16, E4, E10, E16, H4, H10, H16
4. Print as PDF ( filename is path &name of file. Change it to what you want)
5. OpenafterPublish = False means after creating PDf don't open it. if you want open file then change False to True

Sub TransferData()
Dim i As Long, j As Long, Lr1 As Long, K As Long, Sh1 As Worksheet, Sh2 As Worksheet
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = Lr1 To 1 Step -1
If Len(Trim(Sh1.Range("A" & i).Value)) = 11 And IsNumeric(Left(Trim(Sh1.Range("A" & i).Value), 4) * 1) Then
Else
Rows(i).Delete
End If
Next i
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Lr1 Step 9
Sh2.Range("B4").Value = Sh1.Range("A" & i).Value
Sh2.Range("E4").Value = Sh1.Range("A" & i + 1).Value
Sh2.Range("H4").Value = Sh1.Range("A" & i + 2).Value
Sh2.Range("B10").Value = Sh1.Range("A" & i + 3).Value
Sh2.Range("E10").Value = Sh1.Range("A" & i + 4).Value
Sh2.Range("H10").Value = Sh1.Range("A" & i + 5).Value
Sh2.Range("B16").Value = Sh1.Range("A" & i + 6).Value
Sh2.Range("E16").Value = Sh1.Range("A" & i + 7).Value
Sh2.Range("H16").Value = Sh1.Range("A" & i + 8).Value
K = K + 1
Sh2.ExportAsFixedFormat Type:=xlTypePDF, Filename:="D:/PrintPDFs/Print" & K & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next i
End Sub

 

[Risque666]

Hey thanks for the reply, Let me get back to you with the Data

 

[Risque666]

Hey thanks for the reply, Let me get back to you with the Data

This is example code if:
1. if all data at column A
2. First sheet name is Sheet1 & 2nd sheet name is Sheet2
3. Cell addresses at Sheet2 is B4, B10, B 16, E4, E10, E16, H4, H10, H16
4. Print as PDF ( filename is path &name of file. Change it to what you want)
5. OpenafterPublish = False means after creating PDf don't open it. if you want open file then change False to True

Sub TransferData()
Dim i As Long, j As Long, Lr1 As Long, K As Long, Sh1 As Worksheet, Sh2 As Worksheet
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = Lr1 To 1 Step -1
If Len(Trim(Sh1.Range("A" & i).Value)) = 11 And IsNumeric(Left(Trim(Sh1.Range("A" & i).Value), 4) * 1) Then
Else
Rows(i).Delete
End If
Next i
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Lr1 Step 9
Sh2.Range("B4").Value = Sh1.Range("A" & i).Value
Sh2.Range("E4").Value = Sh1.Range("A" & i + 1).Value
Sh2.Range("H4").Value = Sh1.Range("A" & i + 2).Value
Sh2.Range("B10").Value = Sh1.Range("A" & i + 3).Value
Sh2.Range("E10").Value = Sh1.Range("A" & i + 4).Value
Sh2.Range("H10").Value = Sh1.Range("A" & i + 5).Value
Sh2.Range("B16").Value = Sh1.Range("A" & i + 6).Value
Sh2.Range("E16").Value = Sh1.Range("A" & i + 7).Value
Sh2.Range("H16").Value = Sh1.Range("A" & i + 8).Value
K = K + 1
Sh2.ExportAsFixedFormat Type:=xlTypePDF, Filename:="D:/PrintPDFs/Print" & K & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next i
End Sub

I actually had another thought.. is there away to say clean up sheet 2 so it only shows me the 400 individual codes and then on sheet 1 I use a macro to import all the Codes into the 400 different places on the WIFI Code sheet, then just print it with out saving them any where.. Print it and then clear the cells for the next weeks codes.

 

[maabadi]

First part of code Clean up sheet2 only you need change sheet2 with sheet1 Then First part of code is this:

Sub TransferData()
Dim i As Long, j As Long, Lr1 As Long, K As Long, Sh1 As Worksheet, Sh2 As Worksheet
Set Sh1 = Sheets("Sheet2")
Set Sh2 = Sheets("Sheet1")
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = Lr1 To 1 Step -1
If Len(Trim(Sh1.Range("A" & i).Value)) = 11 And IsNumeric(Left(Trim(Sh1.Range("A" & i).Value), 4) * 1) Then
Else
Rows(i).Delete
End If
Next i
End Sub

For 2nd Part, I should now places address (400 Places) to put codes to them and then Clear them.
I give you example,
Please give me minimum first 9 cell to I know other Cells based them & then write macro?

 

[Fluff]

Depending on you actual data this should put the codes into column B without blanks

Sub Risque()
   With Range("A1", Range("A" & Rows.Count).End(xlUp))
      .Offset(, 1).Value = Evaluate("if(right(" & .Address & ",4)=""days""," & .Offset(1).Address & ","""")")
      .Offset(, 1).SpecialCells(xlBlanks).Delete xlShiftUp
   End With
End Sub

 

[Risque666]

Depending on you actual data this should put the codes into column B without blanks

Sub Risque()
   With Range("A1", Range("A" & Rows.Count).End(xlUp))
      .Offset(, 1).Value = Evaluate("if(right(" & .Address & ",4)=""days""," & .Offset(1).Address & ","""")")
      .Offset(, 1).SpecialCells(xlBlanks).Delete xlShiftUp
   End With
End Sub

This is where the Codes will go. So the Wifi Insert is the Cells Merged highlighted in red but also the others in the rest of the document.
i.e. c23 k23 s23 and then c37 and so on. this is sheet 1 - Sheet 2 is how the codes will appear that i want tidied up so all 400 codes on the document end up from a1 to 1400 with out all the other crap like the """Valid for 8 days, ""unlimited "" upload speed"" etc gone.
Then once all 400 codes are in cells a1 to a400 I can import them all in to the merged cells on all 400 Wife Inserts

 

[Fluff]

Have you tried my code in post#7 or maabadi's code in post#6?

 

[maabadi]

This code print Data with Default Printer.
Change sheet1 & Sheet2 to Your Sheet Names.
Take Backup before test code.
Save file as Macro-Enabled Workbook (.xlsm).

Try this:

Sub TransferData()
Dim i As Long, j As Long, Lr1 As Long, K As Long, Sh1 As Worksheet, Sh2 As Worksheet
Dim M As Long, N As Long
Set Sh1 = Sheets("Sheet2")
Set Sh2 = Sheets("Sheet1")
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlUp).Row
Lc1 = Sh1.Cells(1, Columns.Count).End(xlToLeft).Column
For i = Lr1 To 1 Step -1
If Len(Trim(Sh1.Range("A" & i).Value)) = 11 And IsNumeric(Left(Trim(Sh1.Range("A" & i).Value), 4) * 1) Then
Else
Rows(i).Delete
End If
Next i
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To Lr1
M = (i - 1) Mod 3
j = M * 8 + 3
N = Int((i + 2) / 3) * 14 + 9
Sh2.Cells(N, j).Value = Sh1.Range("A" & i).Value
Next i
Sh2.PrintOut Preview:=True, IgnorePrintAreas:=False
For i = 1 To Lr1
M = (i - 1) Mod 3
j = M * 8 + 3
N = Int((i + 2) / 3) * 14 + 9
Sh2.Cells(N, j).ClearContents
Next i
Sh1.Range("A1:A" & Lr).ClearContents
End Sub